Built . It shows the files as they were then (ages and “working now” follow your clock).
tools/rebuild_pages.sh rebuilds the site within 5 minutes of a change; by hand: python3 -B tools/site.py.Machines / #14
1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB
How we proved it never halts
Walls that never collide, and a counter on a fixed schedule
Each time the head walks in from the left edge and back, it delivers one carry into a long row of short blocks, like the input wheel of an odometer. Digit blocks count in binary (0000 is a 0, 1000 a 1), and wire blocks 11000 pass carries straight through. Walls (111000 or 011000) swallow every second carry; on the others a wall sends three carries onward and creeps one block to the right.
A small gadget at the left end repeats exactly, adding 8 new walls every 8 times the head reaches fresh tape there. The walls ride the wire in single file and are swallowed one by one by a binary counter at the far right. The machine can halt only after a hit: a creeping wall pushing into a block that is not wire or a plain digit, such as another wall.
The key idea: on the wire a hit is impossible, since three carries always turn the block ahead of a creeping wall into wire. At the far counter, a bookkeeping identity shows that the carries arriving between two swallowed walls depend only on the wall's place in the cycle of 8 and on how far the counter's edge has moved. So the counter runs on a fixed schedule, which the proof shows never produces a hit.
Why that settles it: at each visit to a fresh cell on the left, two counts (visits so far, walls swallowed) fix the whole tape, and that description carries over to the next visit with no hit on the way. The first such visit comes at step 203,465, so the machine never halts.
The Rocq proof checks each block's rule by running the machine on that block alone, the rest of the tape a black box. Computation covers the gadget, the opening and thousands of representative counter runs; the visit-to-visit step is proved for all 8 kinds of visit.
#26local proof number
4,422lines of Rocq
316 sto compile
6/6automatic checks
About this picture
The standard picture (bbchallenge.org's Default view): each row is the whole tape at one step, time runs downward, and the head's path draws the pattern.
bbchallenge-defaultStart blankRows steps 0 → 10,000, top to bottomWindow cells −200..199, left to rightColors 1 0 or unvisited
Claimed by someone else
We proved this machine locally, but our proof was still unsubmitted when we found it already covered upstream.
Submit completed proofs early. A local proof does not secure an upstream claim.
Upstream proof ↗ · Recorded timeline
What the timing evidence establishes
This describes upstream credit, not who first discovered the mathematics. The records do not establish adoption of our proof, first public push time, or whether an earlier submission would have secured credit.
Overview
In one sentence
Period-5 tape; 5-state walls drift right x1.5 per level (3/2 conveyor); right-edge counter absorbs them; no halt branch.
Submitted mechanism Carries. Read the tape as a word of units D0 = 0000, D1 = 1000, P = 11000, S1 = 01000, SP = 011000, W = 111000. Each walk of B to the right and C back from the left edge is one carry, and it acts on the unit word as a recursive increment (Theorem U). (submission/README.md, Mechanism)
- Upstream
- The blank-start machine never halts: BLECv5.v.TM4 ↗. We also have a local proof. This upstream addition is separate from our merged submissions; adoption credit is not established. Recorded commit time: 2026-10-15T06:57:40Z. First public push time is not established.
- Rocq proof
- check_kill PASS · first Oct 13 05:104,422 lines · 206 KB .v · compile 315.6 s · coqchk pass · 0 axioms · PASS Oct 13 05:10· the .v file
- Automatic review
- 6 of 6 checks passtemplate: verify/CounterCmp_v1.v Module TM1 (nearest template) · details in Proof →
- Class
- Structural counter + counterours: sheet Structural counter + counter ≠ ours 3/2 wall conveyor (rational-base counter) + right-edge counter · med confidence
- On the list
- not on
BB6_holdouts_663.txt(line 301 of the previous list) · historical 740 line 301
Your calls on file 7
- 2026-10-10 · chain_stage
- Spend one more targeted stage testing whether the conveyor's absorption intervals can ever give one wall three hits, flag the machine as a cryptid candidate now, or park? (auto-applied: Claude's recommendation, under Dennis's standing instruction 'do your recommendations and continuously orchestrate' (2026-10-10, while he was at lunch). Override any time.)
- 2026-10-10 · law_stage
- Spend one more targeted stage deriving the absorption-interval law and the no-survivor zone lemma, start proof.md now with both as lemmas to prove, or park? (auto-applied: Claude's recommendation, under Dennis's standing instruction 'do your recommendations and continuously orchestrate' (2026-10-10, while he was away). Override any time.)
- 2026-10-12 · marker_stage
- Spend one more stage proving a marker-descent lemma uniform in the marker height (the block map for every ruler class), start proof.md now with it open, or park? (Dennis: apply recommendations (2026-10-12))
- 2026-10-12 · nested_stage
- Spend one more stage on the nested-marker lemma (and the o = 1 entry), start proof.md now with it open, or park? (Dennis: b (fund all five), 2026-10-12)
- 2026-10-10 · targeted_deepen
- Spend one short targeted stage on rules for the shift-on-wall (0111000) states before proof.md, start proof.md now with the wrap coincidence as an open lemma, or park? (Dennis: go with all recommendations (2026-10-10))
- 2026-10-11 · top_system
- Spend one more stage deriving the intervals from the closed conveyor-top + zone system and proving the zone lemma by induction over 32-blocks, start proof.md now with both open, or park? (Dennis: go with recommendations (2026-10-11))
- 2026-10-12 · vf_round
- #14's proof is down to one major gap (lemma VF and the plant step for v > 600): fund one more revision round to close it, or park #14? (Dennis 2026-10-12: 'go with recommendations')
Mechanism
What to check here: the pictures show the mechanism that the rule table describes.
How it works: 3 notes
- Tape = period-5 pattern: B sweeping right turns 11000 into 10111; C sweeping left turns it back (5 steps/block).
- Walls are 5-state gadgets: B bounces once then passes, C twice then passes; each round moves a wall 5 cells right.
- So each wall is crossed 3/2 as often as the one to its left; walls are born at the left, absorbed at the right.
Figures for Checkpoint A
Every 8 steps. Long vertical lines are walls; follow the head's sweeps and where they turn back.
bbchallenge-defaultStart mid-run: step 1,139,175Rows every 8 stepsWindow cells -99..366, 1 px = 1 cellColors 1 0 head after a right/left move
Start: same tape as Fig 2, head at cell -97 · Rows: steps 1,139,175 + 0, 8, ..., 16,000 (2,001 rows) · Window: the whole tape · Colors: Whiter stripes =
10111 (swept right by B), darker stripes = 11000 (swept left by C); the slanted edges between them are the head sweeping, ~8 cells per rowEvery 100 steps; colour edges are walls. Follow one band down: its position, its width, where it starts and ends.
customStart mid-run: step 1,139,175Rows every 100 stepsWindow cells -104..398, 1 px = 1 cellColors the period-4 zone at the right barrier cells in no pattern (0/1) not yet visited
Start: a left record; tape in
cfg_step1139175_pos-97.txt, head at cell -97 · Rows: steps 1,139,200, 1,139,300, ..., 1,469,300 (3,302 rows) · Window: the whole tape · Colors: the tape repeats a 5-cell block (11000, or 10111 after a right sweep); colour = which of its 5 shifts a cell is in, so every colour boundary is a wall (a +1 shift); head not drawnMore figures (5)Fig 3–7: bbchallenge Default view, first 10,000 steps · Edge records to 100 million steps · Blaze view, 100 million steps · Marker descent and the nested marker · Lemma L′: one step, three marker heights
For orientation: the period-5 stripes as bbchallenge.org shows them.
bbchallenge-defaultStart blankRows every step: steps 0..9,999 squeezed into 500 px rows as on bbchallenge.orgWindow cells -200..199, 1 px = 1 cellColors 1 0 or never visited head after a right/left move
Rows: each px row blends steps 20y+9 and 20y+10, so 1 px row = 20 steps · Colors: red/green: pale colours = blended by the squeeze
Fig 4 · Edge records to 100 million steps
The right edge gains 1,586 cells, the left edge 406: about 4 to 1.
bbchallenge-defaultStart blankRows the start, then one per new leftmost or rightmost cellWindow cells -406..1,586, 1 px = 1 cellColors 1 0 or never visited head on a new right/left cell
Rows: (1,993 rows, steps 0..100,000,000); not evenly spaced in time
Fig 5 · Blaze view, 100 million steps
Both edges keep growing, ever slower (span ~ t^(1/3)); walls are too fine to see.
bbchallenge-blazeStart blankRows time blocks of 131,072 stepsWindow cells -406..1,587, 1 px = ~2.5 cellsColors 0 1
Rows: averaged (763 blocks, steps 0..100,000,000), stretched to 500 px: 1 px ~ 200,000 steps · Window: Blaze averages 2 cells per column; its 997 columns are stretched to 800 px · Colors: in-between shades = both mixed inside the pixel's block (averaged); no head
Fig 6 · Marker descent and the nested marker
Each orange diagonal is a marker sinking one unit per row; the second starts where the first ends.
customStart constructed: zone of class k = 240 - 9Rows one row per closed-system stepWindow zone units 0..59 from the zone bottomColors 0 digit 1 digit P unit (the markers) S1 head wall head (SP/W) above the zone's top unit
Start: (o = 3) at marker height 46 (deepen7 value form; scripts/deepen8/fig_nested.py) · Rows: (one absorption at the zone bottom), 113 rows from marker height 46 to the next canonical state · Window: (tape order, left = bottom); 1 unit = 4-5 tape cells, drawn 6 px wide
Fig 7 · Lemma L′: one step, three marker heights
Left of each green tick the pair rows match across all three; only the orange marker height differs.
customStart constructed tape (below)Rows three pairs of rowsWindow zone units 0..71 from the zone bottomColors 0 digit 1 digit P unit (the marker) S1 head above the zone top tick: the cut after digit 7
Start: value-form zones VF(k, o*2k+5, off) at phase 1: representative k = 20 · off = 33 (marker height 11); members k = 300, off = 289 (height 35) and k = 581, off = 545 (height 60) (scripts/proof4/fig_lprime.py) · Rows: 10 px each: the zone before one closed-system step (top) and after it (bottom); representative, then the two members · Window: (tape order, left = bottom); 1 unit = 4-6 tape cells, drawn 6 px wide · Colors: green tick: after digit 6 in the bottom rows, one digit lost to the landing
Rules (11/11 validated)exact tape rewrites the proof will formalize, each re-checked by simulation
| rule | from ⟶ to | cases | steps | checked |
|---|---|---|---|---|
| S_R: B sweeps right, dark -> light | B> (11000)n ⟶ (10111)n B> | — | 5n | ✓140/140 |
| S_L: C sweeps left, light -> dark (C on 0) | (11110)n <C ⟶ <C (00011)n | — | 5n | ✓140/140 |
| S_L': C sweeps left, light -> dark (C on 1) | (10111)n <C ⟶ <C (11000)n | — | 5n | ✓140/140 |
| EdgeR: right edge grows 4 cells | E> 0∞ ⟶ 13 <C 1 0∞ | — | 4 | ✓140/140 |
| EdgeL: left edge grows 2 cells | 0∞ <C ⟶ 0∞ 1 0 B> 1 | C on the blank left of the tape | 4 | ✓140/140 |
| Wall W0 reflects B (wall -> W1) | B> (11000)n 0 ⟶ <C (11000)n 1 | — | 10n+1 | ✓140/140 |
| Wall W1 lets B pass (wall -> Lw1) | B> (11000)n 1 (11000)m ⟶ (10111)n 1 00111 (10111)m-1 B> | m >= 1 | 5n+5m+1 | ✓140/140 |
| Wall Lw1 reflects C (-> Lw2) | 1 00111 (10111)m <C ⟶ 000111 (10111)m B> | — | 10m+11 | ✓140/140 |
| Wall Lw2 reflects C (-> Lw3) | 000111 (10111)m <C ⟶ 101111 (10111)m B> | — | 10m+11 | ✓140/140 |
| Wall Lw3 lets C pass (-> W0, moved 5 cells right) | 101111 (10111)m <C ⟶ <C 110000 (11000)m | — | 5m+6 | ✓140/140 |
| Cycle (2 left records): prefix repeats, last segment grows | 0∞ <C 16 0 (00011000011)2 (00011)2 (10001)3 10 (00011)6 (10001)8 (11000)12 1 (11000)18 (01100)27 02 (11000)41 (01100)61 (00110)92 (00011)138 (10001)206 (11000)a R 0∞ ⟶ 0∞ <C 16 0 (00011000011)2 (00011)2 (10001)3 10 (00011)6 (10001)8 (11000)12 1 (11000)18 (01100)27 02 (11000)41 (01100)61 (00110)92 (00011)138 (10001)206 (11000)a' R' 0∞ | a'-a in 4..12, depends on a and on R (4 barrier states tried); left edge -8 | ~1.2e7-3.3e7 at a=60..300 | ✓40/40 |
Compressed historythe tape as 0∞ <C 16 0 (00011000011)2 (00011)2 (10001)3 10 (00011)6 (10001)8 (11000)12 1 (11000)18 (01100)27 02 (11000)41 (01100)61 (00110)92 (00011)138 (10001)206 (11000)a R 0∞ at 28 moments: where the rules are read off
0∞ <C 16 0 (00011000011)2 (00011)2 (10001)3 10 (00011)6 (10001)8 (11000)12 1 (11000)18 (01100)27 02 (11000)41 (01100)61 (00110)92 (00011)138 (10001)206 (11000)a R 0∞
| step | a | R (right barrier) | left edge | right edge |
|---|---|---|---|---|
| 411,292,299 | 6 | 0 0001^3 0^11 1000^2 0^8 1 | -641 | 2,534 |
| 427,176,127 | 14 | 0 0001^2 0^15 1000^2 0^8 1 | -649 | 2,566 |
| 443,460,527 | 22 | 0 0001^5 0^7 1 0^11 1 | -657 | 2,598 |
| 460,105,357 | 26 | 1 0^3 10001^3 100010001^2 (0^11 1)^2 | -665 | 2,630 |
| 477,204,309 | 38 | 0 0001^3 00000001^2 0^11 1 | -673 | 2,662 |
| 494,734,751 | 46 | 0 0001^2 0^11 1 0^7 1 0^11 1 | -681 | 2,694 |
| 512,686,083 | 54 | 0 0001^4 (0^11 1)^2 | -689 | 2,726 |
| 531,040,305 | 58 | 10001^4 1 0^15 (1 0^11)^2 1 | -697 | 2,758 |
| 549,883,439 | 70 | 0 0001^3 0^15 1 0^11 1 | -705 | 2,790 |
| 569,142,415 | 78 | 0 0001^2 0^19 1 0^11 1 | -713 | 2,822 |
| 588,842,575 | 86 | 0 0001^6 0^15 1 | -721 | 2,854 |
| 608,951,643 | 90 | 1 0^3 10001^5 0^11 1000^2 0^12 1 | -729 | 2,886 |
| 629,570,677 | 102 | 0^4 1000^3 0 0001^2 0^15 1 | -737 | 2,918 |
| 650,640,107 | 110 | 0 0001^2 0^11 1000^2 0^12 1 | -745 | 2,950 |
| 672,171,047 | 118 | 0 0001^4 0^7 1 0^15 1 | -753 | 2,982 |
| 694,146,827 | 122 | 10001^4 1 0^15 1 0^7 1 0^15 1 | -761 | 3,014 |
| 716,650,569 | 134 | 0 0001^3 0^11 1 0^15 1 | -769 | 3,046 |
| 739,612,373 | 142 | 0 0001^2 (0^15 1)^2 | -777 | 3,078 |
| 763,055,989 | 150 | 0 0001^5 0^19 1 | -785 | 3,110 |
| 786,944,905 | 154 | 1 0^3 10001^3 0^3 1^2 0^7 10001^2 0001^4 | -793 | 3,138 |
| 811,350,253 | 166 | 0 0001^3 0^7 1 0^19 1 | -801 | 3,174 |
| 836,286,351 | 174 | 0 0001^2 0^11 1 0^19 1 | -809 | 3,206 |
| 861,724,579 | 182 | 0 0001^4 0^23 1 | -817 | 3,238 |
| 887,649,597 | 186 | 10001^4 1 0^15 1 0^23 1 | -825 | 3,270 |
| 914,141,627 | 198 | 0 0001^3 0^27 1 | -833 | 3,302 |
| 941,133,939 | 206 | 0 0001^2 0^31 1 | -841 | 3,334 |
| 968,648,651 | 214 | 0 0001^9 | -849 | 3,362 |
| 996,656,845 | 218 | 1 0^3 10001^5 0^8 0001^5 | -857 | 3,394 |
alast 218R (right barrier)last 1 0^3 10001^5 0^8 0001^5not plottable
left edgelast -857right edgelast 3,394Template comparisonCounterCmp_v1.v TM1: does not apply · the nearest solved proof, what carries over, and the transitions that differ
| 0 | 1 | |
|---|---|---|
| A | 1RB | --- |
| B | 1LC | 1RE |
| C | 1LD | 0LC |
| D | 1LE | 1LC |
| E | 1RF | 0RE |
| F | 1RA | 0RB |
differs from the template
- file
CounterCmp_v1.v:9- module
TM1- machine
1RB0LD_1RC0RE_0LA0RC_1LB1LD_0LF1RE_---1LA(11 transitions apart)- diff
11/12 transitions differ (only A0=1RB shared)- note
- Template compares two unary counters (x -> 2x-1, sigma_score_unbounded_nonhalt). From its S1/Inc_a configs our machine hits 0/60 targets and halts 25/60; only its Inductive trip relation P is reusable.
Proof strategy & riskshow the formal proof will go · 3 risks to watch
Prove sweeps with ind and the 5 wall rules with es. Encode the tape as a list of (segment length, wall state) with an Inductive trip relation (CounterCmp_v1 P, BECv7 digit encoding); prove one head trip by induction on the list, then a closed invariant (left gadget + list + right barrier) and finish with progress_nonhalt_cond / multistep_nonhalt.
- ▲Right barrier (0001 zone) is a second counter: last-segment growth per cycle is 4-12 blocks depending on a; needs its own case analysis.
- ▲Exact wall spacings follow a 3/2 rounding orbit; the invariant must bound them, not pin them (200/200 perturbed tapes ran 1e8 steps without halting).
- ▲No proof in this class yet; nested trip induction may give a 30-60 KB file.
Stats & provenance109 steps simulated · 4,258 cells · the status in full · files
- simulated
- 109 steps
- tape
- 4,258 cells · 2,660 nonzeros
- growth
- span ~ t^0.33 (445 / 935 / 1,993 / 4,258 cells at 1e6 / 1e7 / 1e8 / 1e9)
- status now
- check_kill PASS, independently re-verified (status.json, 2026-10-13)
- observer's note
- Mechanism found: 3/2 wall conveyor + right-barrier counter. 10 local rules 1400/1400, cycle shape 40/40. No halting branch seen; the 3/2 arithmetic only sets wall spacings, so not flagged cryptid.
- files
- observe.json · notes.md · proof.md · how_proved.md · status.json · 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v
Proof & checks
6/6 automatic checks pass
Kill 26 · Structural counter + counter · the kill file 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v: 4422 lines, 416 items · the package submission/
✓ 6/6 automatic checks pass · Checkpoint B: no note from Dennis yet · template (nearest template): verify/CounterCmp_v1.v Module TM1 · 1% of our lines identical
1What is provedCheck: the string, the theorem and every check_kill line are green, and the .v on disk is the one that was checked (same sha256).
Machine
1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RBvs holdout list
Theorem
check_kill
✓ PASS
· 17/17 checks pass
· compile 315.55 s · coqchk pass
(299.9 s) · assumptions: 0
(closed)
· 2026-10-13 12:10:55 UTC
· submission/check_kill.txt
Checked .v
sha256 a4144ade7c58e6c1…
| ✓ | 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v | a4144ade7c58e6c1… = checked |
| ✓ | submission/1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v | a4144ade7c58e6c1… = checked |
Status
✓Killed: never halts
updated 2026-10-13
✓ args✓ input✓ framework✓ framework_build✓ forbidden✓ structure✓ tm_text✓ theorem_text✓ coq✓ names✓ compile✓ tm_rocq✓ theorem_rocq✓ isolation✓ assumptions✓ coqchk✓ integrity
All 17 check_kill checks with their one-line results
| ✓ | args | 6x2 machine, framework module Individual62, mode nonhalt |
| ✓ | input | 211270 bytes, 4422 lines, 4701 sentences |
| ✓ | framework | HEAD 0940bb9cf434ba68f0c025dabfde45a219999973 == pin; no tracked changes under verify/ |
| ✓ | framework_build | 13 needed framework .vo files present and fresh, with native code no older than the .vo |
| ✓ | forbidden | none of 30 forbidden patterns occur (ground rule 1's words: anywhere; command words: outside comments and strings; comments never split a token) |
| ✓ | structure | 8 Require name(s) allowed; no top-level Variable/Context; no shadowing; Module/Section balanced |
| ✓ | tm_text | line 59: TM_from_str "1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB" == <tm> (41 bytes) |
| ✓ | theorem_text | line 4343: nonhalt : ~halts tm c0 |
| ✓ | coq | coqc 8.20.1 (<opam-switch>/bin/coqc) |
| ✓ | names | halts, c0, TM_from_str resolved inside Individual62 |
| ✓ | compile | compiled in 315.6s with all appended checks |
| ✓ | tm_rocq | BB6Kill.Candidate.tm = BusyCoq.Individual62.TM_from_str "1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB" by eq_refl (in-file and isolated) |
| ✓ | theorem_rocq | nonhalt : ~ halts (TM_from_str "1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB") c0 with absolute names (in-file and isolated) |
| ✓ | isolation | only stock proof plugins loaded; guard/positivity/universe checking on, definitional UIP off |
| ✓ | assumptions | 0 assumption(s), all in the baseline |
| ✓ | coqchk | coqchk -norec BB6Kill.Candidate ok (299.9s); its context summary lists nothing of the file's own |
| ✓ | integrity | input sha256 and framework HEAD/cleanliness identical before and after |
2Where it came fromCheck: the template is the one you expect, and the measured reuse (tiles, the reuse figure, diff) agrees with what the README says was kept and changed (quoted).
nearest template
verify/CounterCmp_v1.v Module TM1
· detected from 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v line 9
1%of our lines identical to the template
0changed lines
3872added lines (ours only)
370template lines dropped
1 / 1 / 414items identical / adapted / new
What the package README says it reused and changed (submission/README.md line 19, Template), quoted:
None in busycoq applies: the nearest, verify/CounterCmp_v1.v Module TM1, differs in 11 of 12 transitions. The .v (4,422 lines) follows only the counter pattern of verify/Example.v (unit lemmas with the arrival on the rest as an argument); everything else is new.
Top two bars: non-blank lines after the TM string is replaced by <TM> and whitespace is collapsed. Bottom bar: our Definitions/Lemmas/… by name.
identicalchanged / adaptedours only (new)template only
Template part: lines 1–8 (shared header, before the first Module) + 10–445 (body of Module TM1; the Module/End lines left out). Ours: lines 53–4422 (header comment 1–52 left out). Line diff: Python difflib SequenceMatcher; inside a replaced block, line pairs at least 75% alike count as changed, the rest as removed + added.Template-only names: S1, Inc1, Incs1, Inc_a, Inc_b, P, P_spec, Q1, Q1_S, Q2, Q3, Q4, Q2_S, Q3_S, Q4_S, Q1_S', Q0, Q2_Q0, Q0_S, Q1_O, Q0_n, pow2_ge
Side-by-side diff: template (407 lines) vs ours (3909 lines), 4242 lines differ; runs of identical lines and long template-only runs folded
identicalequal once each TM string is <TM>changedours onlytemplate only
| template | ours | ||
|---|---|---|---|
| 1 | From BusyCoq Require Import Individual62. | 54 | From BusyCoq Require Import Individual62. |
| 2 | Require Import ZifyNat Lia. | ||
| 55 | Require Import Lia String List Arith. | ||
| 3 | Require Import ZArith. | ||
| 56 | From Coq Require Import PArith NArith ZArith. | ||
| 4 | Require Import String. | ||
| 57 | Import ListNotations. | ||
| 5 | From BusyCoq Require Import BinaryCounter_v2. | ||
| 6 | From BusyCoq Require Import Longitudinal. | ||
| 11 | Definition tm := Eval compute in (TM_from_str "1RB0LD_1RC0RE_0LA0RC_1LB1LD_0LF1RE_---1LA"). | 59 | Definition tm := Eval compute in (TM_from_str "1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB"). |
| 61 | Notation "c --> c'" := (c -[ tm ]-> c') (at level 40). | ||
| 13 | Notation "c -->* c'" := (c -[ tm ]->* c') (at level 40). | 62 | Notation "c -->* c'" := (c -[ tm ]->* c') (at level 40). |
| 14 | Notation "c -->+ c'" := (c -[ tm ]->+ c') (at level 40). | 63 | Notation "c -->+ c'" := (c -[ tm ]->+ c') (at level 40). |
| 16 | Definition S1 l a b c := | ||
| 65 | (* ===================================================================== *) | ||
| 17 | l <* [1]^^a <{{B}} [1]^^b *> [1;0]^^(1+c) *> 0inf. | ||
| 66 | (* 1. Arrivals on sides: one carry entering a side in state B and *) | ||
| 19 | Lemma Inc1 l a b c: | ||
| 67 | (* coming back in state C. *) | ||
| 20 | S1 l (1+a) (1+b) c -->* | ||
| 68 | (* ===================================================================== *) | ||
| 21 | S1 l a b (1+c). | ||
| 70 | Definition ArrS (r r' : side) : Prop := forall l, l {{B}}> r -->* l <{{C}} r'. | ||
| 72 | (* first cell 0: B0 -> 1LC *) | ||
| 73 | Lemma arr_Z r : ArrS (0 >> r) (1 >> r). | ||
| 74 | Proof. intros l. execute. Qed. | ||
| 76 | (* D1: B> 1000 r --> 1111 B> r ~> 1111 <C r' --> <C 0000 r' *) | ||
| 77 | Lemma arr_D1 r r' : ArrS r r' -> ArrS ([1;0;0;0] *> r) ([0;0;0;0] *> r'). | ||
| 22 | Proof. | 78 | Proof. |
| 23 | es. | ||
| 79 | intros H l. cbn [Str_app]. | ||
| 80 | do 4 step. follow H. execute. | ||
| 24 | Qed. | 81 | Qed. |
| 26 | Lemma Incs1 n l a b c: | ||
| 83 | (* P: B> 11000 r --> 10111 B> r ~> 10111 <C r' --> <C 11000 r' *) | ||
| 27 | S1 l (n+a) (n+b) c -->* | ||
| 84 | Lemma arr_P r r' : ArrS r r' -> ArrS ([1;1;0;0;0] *> r) ([1;1;0;0;0] *> r'). | ||
| 28 | S1 l a b (n+c). | ||
| 29 | Proof. | 85 | Proof. |
| 30 | gen a b c. | ||
| 86 | intros H l. cbn [Str_app]. | ||
| 31 | ind n Inc1. | ||
| 87 | do 5 step. follow H. execute. | ||
| 32 | Qed. | 88 | Qed. |
| 34 | Notation "l <| r" := (l <{{D}} r) (at level 30). | ||
| 90 | (* W: B> 111000 r --> 100111 B> r ~> 100111 <C r1 --> 000111 B> r1 ~> ... | ||
| 36 | Lemma Inc_a l a b: | ||
| 91 | --> 101111 B> r2 ~> 101111 <C r3 --> <C 110000 r3 *) | ||
| 37 | a<=b -> | ||
| 92 | Lemma arr_W r r1 r2 r3 : ArrS r r1 -> ArrS r1 r2 -> ArrS r2 r3 -> | ||
| 38 | l <* [0] <* [1]^^a <* [0] <* [1]^^b <| 0inf -->* | ||
| 93 | ArrS ([1;1;1;0;0;0] *> r) ([1;1;0;0;0;0] *> r3). | ||
| 39 | l<*[1]<*[0]^^(b-a)<*[1]^^(a*2+1) <| 0inf. | ||
| 40 | Proof. | 94 | Proof. |
| 41 | intros. | ||
| 95 | intros H1 H2 H3 l. cbn [Str_app]. | ||
| 42 | mid (S1 (l<<0) a b 0). | ||
| 96 | do 6 step. follow H1. | ||
| 43 | 1: es. | ||
| 97 | do 11 step. follow H2. | ||
| 44 | mid (S1 (l<<0) (a+0) (a+(b-a)) 0). | ||
| 98 | do 11 step. follow H3. | ||
| 45 | 1: finish. | ||
| 99 | execute. | ||
| 46 | follow Incs1. | ||
| 47 | es. | ||
| 48 | Qed. | 100 | Qed. |
| 50 | Lemma Inc_b l a b: | ||
| 102 | (* ===================================================================== *) | ||
| 51 | b<a -> | ||
| 103 | (* 2. Units and unit words; one carry (Inc); Theorem U (arrival = Inc). *) | ||
| 52 | halts tm (l <* [0] <* [1]^^a <* [0] <* [1]^^b <| 0inf). | ||
| 104 | (* ===================================================================== *) | ||
| 106 | Inductive unt := uD0 | uD1 | uP | uS1 | uSP | uW. | ||
| 108 | Definition ucells (u : unt) : list Sym := | ||
| 109 | match u with | ||
| 110 | | uD0 => [0;0;0;0] | ||
| 111 | | uD1 => [1;0;0;0] | ||
| 112 | | uP => [1;1;0;0;0] | ||
| 113 | | uS1 => [0;1;0;0;0] | ||
| 114 | | uSP => [0;1;1;0;0;0] | ||
| 115 | | uW => [1;1;1;0;0;0] | ||
| 116 | end. | ||
| 118 | Fixpoint enc (w : list unt) : list Sym := | ||
| 119 | match w with | ||
| 120 | | [] => [] | ||
| 121 | | u :: w' => ucells u ++ enc w' | ||
| 122 | end. | ||
| 124 | Definition Rs (w : list unt) : side := enc w *> const 0. | ||
| 126 | Lemma Rs_cons u w : Rs (u :: w) = ucells u *> Rs w. | ||
| 127 | Proof. unfold Rs. cbn [enc]. apply Str_app_assoc. Qed. | ||
| 129 | Lemma enc_app a b : enc (a ++ b) = enc a ++ enc b. | ||
| 130 | Proof. induction a as [|u a IH]; cbn; [reflexivity|]. rewrite IH, app_assoc. reflexivity. Qed. | ||
| 132 | Lemma Rs_app a b : Rs (a ++ b) = enc a *> Rs b. | ||
| 133 | Proof. unfold Rs. rewrite enc_app. apply Str_app_assoc. Qed. | ||
| 135 | (* The shift: one extra 0 cell, re-read as units. It passes D0 units and | ||
| 136 | prepends 0 to the head of the first other unit; on S1, SP or W it is a | ||
| 137 | hit, which is not a unit word. *) | ||
| 138 | Fixpoint shift (w : list unt) : option (list unt) := | ||
| 139 | match w with | ||
| 140 | | [] => Some [] | ||
| 141 | | uD0 :: w' => | ||
| 142 | match shift w' with | ||
| 143 | | Some w'' => Some (uD0 :: w'') | ||
| 144 | | None => None | ||
| 145 | end | ||
| 146 | | uD1 :: w' => Some (uS1 :: w') | ||
| 147 | | uP :: w' => Some (uSP :: w') | ||
| 148 | | _ => None | ||
| 149 | end. | ||
| 151 | Lemma shift_spec w w' : shift w = Some w' -> 0 >> Rs w = Rs w'. | ||
| 53 | Proof. | 152 | Proof. |
| 54 | intros. | ||
| 153 | revert w'; induction w as [|u w IH]; intros w' H; cbn in H. | ||
| 55 | eapply halts_evstep. | ||
| 154 | - inversion H; subst. unfold Rs. cbn. symmetry. apply const_unfold. | ||
| 56 | 2:{ | ||
| 155 | - destruct u; try discriminate. | ||
| 57 | mid (S1 (l<<0) a b 0). | ||
| 156 | + destruct (shift w) as [w''|] eqn:E; [|discriminate]. | ||
| 58 | 1: es. | ||
| 157 | inversion H; subst. rewrite !Rs_cons. rewrite <- (IH w'' eq_refl). reflexivity. | ||
| 59 | mid (S1 (l<<0) (b+(1+(a-b-1))) (b+0) 0). | ||
| 158 | + inversion H; subst. rewrite !Rs_cons. reflexivity. | ||
| 60 | 1: finish. | ||
| 159 | + inversion H; subst. rewrite !Rs_cons. reflexivity. | ||
| 61 | follow Incs1. | ||
| 62 | finish. | ||
| 63 | } | ||
| 64 | esx. | ||
| 65 | Qed. | 160 | Qed. |
| 67 | Open Scope nat. | ||
| 162 | (* One carry entering a unit word at its left end. *) | ||
| 69 | Inductive P: (nat*nat+nat*nat)->(nat*nat+nat)->Prop := | ||
| 163 | Inductive Inc : list unt -> list unt -> Prop := | ||
| 70 | | P1 a b c: | ||
| 164 | | Inc_nil : Inc [] [uD1] | ||
| 71 | a <= b -> | ||
| 165 | | Inc_D0 w : Inc (uD0 :: w) (uD1 :: w) | ||
| 72 | P (inr (b-a,a*2+1)) (inr (c)) -> | ||
| 166 | | Inc_S1 w : Inc (uS1 :: w) (uP :: w) | ||
| 73 | P (inl (a,b)) (inr (1+c)) | ||
| 167 | | Inc_SP w : Inc (uSP :: w) (uW :: w) | ||
| 74 | | P2 a b c d: | ||
| 168 | | Inc_D1 w w' : Inc w w' -> Inc (uD1 :: w) (uD0 :: w') | ||
| 75 | a <= b -> | ||
| 169 | | Inc_P w w' : Inc w w' -> Inc (uP :: w) (uP :: w') | ||
| 76 | P (inr (b-a,a*2+1)) (inl (c,d)) -> | ||
| 170 | | Inc_W w w1 w2 w3 w4 : Inc w w1 -> Inc w1 w2 -> Inc w2 w3 -> shift w3 = Some w4 -> | ||
| 77 | P (inl (a,b)) (inl (1+c,d)) | ||
| 171 | Inc (uW :: w) (uP :: w4). | ||
| 78 | | P3 b: | ||
| 173 | (* Theorem U *) | ||
| 79 | P (inr (0,b)) (inr b) | ||
| 174 | Theorem inc_arr w w' : Inc w w' -> ArrS (Rs w) (Rs w'). | ||
| 80 | | P4 a b c: | ||
| 175 | Proof. | ||
| 81 | P (inr (a,b)) (inr c) -> | ||
| 176 | induction 1. | ||
| 82 | P (inr (1+a,b)) (inl (0,c)) | ||
| 177 | - assert (E1 : Rs [] = 0 >> const 0) by (unfold Rs; cbn; apply const_unfold). | ||
| 83 | | P5 a b x0 x: | ||
| 178 | assert (E2 : Rs [uD1] = 1 >> const 0). | ||
| 84 | P (inr (a,b)) (inl x0) -> | ||
| 179 | { unfold Rs. cbn. f_equal. rewrite <- !const_unfold. reflexivity. } | ||
| 85 | P (inl x0) x -> | ||
| 180 | rewrite E1, E2. apply arr_Z. | ||
| 86 | P (inr (1+a,b)) x | ||
| 181 | - rewrite !Rs_cons. apply arr_Z. | ||
| 87 | . | ||
| 182 | - rewrite !Rs_cons. apply arr_Z. | ||
| 89 | Close Scope nat. | ||
| 183 | - rewrite !Rs_cons. apply arr_Z. | ||
| 91 | Lemma P_spec x y: | ||
| 184 | - rewrite !Rs_cons. apply arr_D1; auto. | ||
| 92 | P x y -> | ||
| 185 | - rewrite !Rs_cons. apply arr_P; auto. | ||
| 93 | forall l, | ||
| 186 | - rewrite !Rs_cons. rewrite <- (shift_spec _ _ H2). | ||
| 94 | match x with | ||
| 187 | change ([1;1;0;0;0] *> 0 >> Rs w3) with ([1;1;0;0;0;0] *> Rs w3). | ||
| 95 | | inl (a,b) => l <* [0] <* [1]^^a <* [0] <* [1]^^b <| 0inf | ||
| 188 | eapply arr_W; eauto. | ||
| 96 | | inr (a,b) => l <* [0]^^a <* [1]^^b <| 0inf | ||
| 189 | Qed. | ||
| 97 | end -->* | ||
| 191 | Lemma Inc_det w a b : Inc w a -> Inc w b -> a = b. | ||
| 98 | match y with | ||
| 192 | Proof. | ||
| 99 | | inl (c,d) => l <* [1]^^c <* [0] <* [1]^^d <| 0inf | ||
| 193 | intros H; revert b; induction H; intros b Hb; inversion Hb; subst; auto. | ||
| 100 | | inr (c) => l <* [1]^^c <| 0inf | ||
| 194 | - f_equal; auto. | ||
| 195 | - f_equal; auto. | ||
| 196 | - assert (w1 = w5) by auto; subst. | ||
| 197 | assert (w2 = w6) by auto; subst. | ||
| 198 | assert (w3 = w7) by auto; subst. | ||
| 199 | congruence. | ||
| 200 | Qed. | ||
| 202 | (* three carries, then the first unit is P and is removed (a pop) *) | ||
| 203 | Definition Inc3Pop (U U' : list unt) : Prop := | ||
| 204 | exists a b, Inc U a /\ Inc a b /\ Inc b (uP :: U'). | ||
| 206 | Fixpoint Pops (k : nat) (U U' : list unt) : Prop := | ||
| 207 | match k with | ||
| 208 | | O => U = U' | ||
| 209 | | S k' => exists U1, Inc3Pop U U1 /\ Pops k' U1 U' | ||
| 101 | end. | 210 | end. |
| 212 | (* ===================================================================== *) | ||
| 213 | (* 3. Window runs: the machine on a finite window, with the rest of the *) | ||
| 214 | (* tape an opaque unit word touched only by the W rule (Inc3Pop). *) | ||
| 215 | (* ===================================================================== *) | ||
| 217 | (* (left cells nearest first, head symbol, right cells, state); the left | ||
| 218 | cells are followed by 0^inf, the right cells by the opaque side X. *) | ||
| 219 | Definition lcfg : Type := (list Sym * Sym * list Sym * Q)%type. | ||
| 221 | Definition lc (X : side) (c : lcfg) : Q * tape := | ||
| 222 | match c with (l, m, r, q) => (q, (l *> const 0, m, r *> X)) end. | ||
| 224 | (* one step; the flag is true when the head leaves the window to the left *) | ||
| 225 | Definition lstep (c : lcfg) : option (lcfg * bool) := | ||
| 226 | match c with | ||
| 227 | | (l, m, r, q) => | ||
| 228 | match tm (q, m) with | ||
| 229 | | None => None | ||
| 230 | | Some (s, L, q') => | ||
| 231 | match l with | ||
| 232 | | [] => Some (([], 0, s :: r, q'), true) | ||
| 233 | | x :: l' => Some ((l', x, s :: r, q'), false) | ||
| 234 | end | ||
| 235 | | Some (s, R, q') => | ||
| 236 | match r with | ||
| 237 | | [] => None | ||
| 238 | | x :: r' => Some ((s :: l, x, r', q'), false) | ||
| 239 | end | ||
| 240 | end | ||
| 241 | end. | ||
| 243 | Lemma lstep_spec X c c' b : lstep c = Some (c', b) -> lc X c --> lc X c'. | ||
| 102 | Proof. | 244 | Proof. |
| 103 | intros HP. | ||
| 245 | destruct c as [[[l m] r] q]. unfold lstep. | ||
| 104 | induction HP; intros. | ||
| 246 | destruct (tm (q, m)) as [[[s d] q']|] eqn:E; [|discriminate]. | ||
| 105 | - follow Inc_a. | ||
| 247 | destruct d. | ||
| 106 | follow. | ||
| 248 | - destruct l as [|x l']; intros H; inversion H; subst. | ||
| 107 | es. | ||
| 249 | + apply (step_left (l := const 0) (r := r *> X) E). | ||
| 108 | - follow Inc_a. | ||
| 250 | + apply (step_left (l := x >> l' *> const 0) (r := r *> X) E). | ||
| 109 | follow. | ||
| 251 | - destruct r as [|x r']; intros H; inversion H; subst. | ||
| 110 | es. | ||
| 252 | apply (step_right (l := l *> const 0) (r := x >> r' *> X) E). | ||
| 111 | - es. | ||
| 112 | - rewrite Nat.add_comm. | ||
| ⋯ 5 template-only lines (template 113–117), not in ours | |||
| 118 | follow. | ||
| 119 | apply IHHP2. | ||
| 120 | Qed. | 253 | Qed. |
| 122 | Open Scope nat. | ||
| 255 | (* the W rule applies: state B on 1, the window ends with 1 1 0 0 0 *) | ||
| 124 | Definition Q1 x s := | ||
| 256 | Definition wready (c : lcfg) : bool := | ||
| 125 | forall a b, | ||
| 257 | match c with | ||
| 126 | a+b=s -> | ||
| 258 | | (_, S1, S1 :: S1 :: S0 :: S0 :: S0 :: [], B) => true | ||
| 127 | 2<=a -> | ||
| 259 | | _ => false | ||
| 128 | x+2<=s -> | ||
| 260 | end. | ||
| 129 | b mod 2 = 1 -> | ||
| 262 | Definition wpop (c : lcfg) : lcfg := | ||
| 130 | P (inr (a,b)) (inl (s-x-1,x)). | ||
| 263 | match c with | ||
| 132 | Ltac ec := econstructor. | ||
| 264 | | (l, _, _, _) => | ||
| 134 | Lemma Q1_S x s: | ||
| 265 | match l with | ||
| 135 | Q1 x s -> | ||
| 266 | | [] => ([], 0, [1;1;0;0;0;0;1;1;0;0;0], C) | ||
| 136 | x+2<=s -> | ||
| 267 | | x :: l' => (l', x, [1;1;0;0;0;0;1;1;0;0;0], C) | ||
| 137 | 1+s<=x*2 -> | ||
| 268 | end | ||
| 138 | Q1 x (1+s). | ||
| 269 | end. | ||
| 271 | Lemma wpop_spec c U U' : wready c = true -> Inc3Pop U U' -> | ||
| 272 | lc (Rs U) c -->* lc (Rs U') (wpop c). | ||
| 139 | Proof. | 273 | Proof. |
| 140 | unfold Q1. | ||
| 274 | intros Hw [a [b [H1 [H2 H3]]]]. | ||
| 141 | intros I2. | ||
| 275 | destruct c as [[[l m] r] q]. | ||
| 142 | intros. | ||
| 276 | assert (HW := arr_W _ _ _ _ (inc_arr _ _ H1) (inc_arr _ _ H2) (inc_arr _ _ H3) (l *> const 0)). | ||
| 143 | assert (a=2\/3<=a) as [E|E] by lia. | ||
| 277 | unfold wready in Hw. | ||
| 144 | - subst a. | ||
| 278 | destruct m; [discriminate|]. | ||
| 145 | ec. | ||
| 279 | destruct r as [|[|] [|[|] [|[|] [|[|] [|[|] [|]]]]]]; try discriminate. | ||
| 146 | 1: do 2 ec. | ||
| 280 | destruct q; try discriminate. | ||
| 147 | replace (1+s-x-1) with (1+(s-x-1)) by lia. | ||
| 281 | rewrite Rs_cons in HW. | ||
| 148 | ec. | ||
| 282 | destruct l as [|x l']; exact HW. | ||
| 149 | 1: lia. | ||
| 150 | apply I2; lia. | ||
| ⋯ 5 template-only lines (template 151–155), not in ours | |||
| 156 | 1: lia. | ||
| 157 | apply I2; lia. | ||
| 158 | Qed. | 283 | Qed. |
| 160 | Definition Q2 x := | ||
| 285 | Fixpoint wrun (fuel : nat) (c : lcfg) : option (lcfg * nat) := | ||
| 161 | P (inr (2,x)) (inl ((x+1)/2,(x+1)/2)) /\ | ||
| 286 | match fuel with | ||
| 162 | forall a b, | ||
| 287 | | O => None | ||
| 163 | a+b=x+2 -> | ||
| 288 | | S f => | ||
| 164 | 2<=a -> | ||
| 289 | if wready c then | ||
| 165 | a<>2 -> | ||
| 290 | match wrun f (wpop c) with | ||
| 166 | b mod 2 = 1 -> | ||
| 291 | | Some (c', k) => Some (c', S k) | ||
| 167 | P (inr (a,b)) (inl (1,x)). | ||
| 292 | | None => None | ||
| 169 | Definition Q3 x := | ||
| 293 | end | ||
| 170 | P (inr (3,x)) (inr (x+3)) /\ | ||
| 294 | else | ||
| 171 | forall a b, | ||
| 295 | match lstep c with | ||
| 172 | a+b=x+3 -> | ||
| 296 | | None => None | ||
| 173 | 2<=a -> | ||
| 297 | | Some (c', true) => Some (c', O) | ||
| 174 | a<>3 -> | ||
| 298 | | Some (c', false) => wrun f c' | ||
| 175 | b mod 2 = 1 -> | ||
| 299 | end | ||
| 176 | P (inr (a,b)) (inl (2,x)). | ||
| 300 | end. | ||
| 178 | Definition Q4 x := | ||
| 302 | Lemma wrun_spec f c c' k : wrun f c = Some (c', k) -> | ||
| 179 | P (inr (4,x)) (inl (0,x+3)) /\ | ||
| 303 | forall U U', Pops k U U' -> lc (Rs U) c -->+ lc (Rs U') c'. | ||
| 180 | forall a b, | ||
| 181 | a+b=x+4 -> | ||
| ⋯ 7 template-only lines (template 182–189), not in ours | |||
| 190 | Q2 x -> | ||
| 191 | Q3 x. | ||
| 192 | Proof. | 304 | Proof. |
| 193 | unfold Q2,Q3. | ||
| 305 | revert c c' k; induction f as [|f IH]; intros c c' k H U U' HP; [discriminate|]. | ||
| 194 | intros Hx Hx0 [I1 I2]. | ||
| 306 | cbn in H. | ||
| 195 | split. | ||
| 307 | destruct (wready c) eqn:Ew. | ||
| 196 | 1: { | ||
| 308 | - destruct (wrun f (wpop c)) as [[c1 k1]|] eqn:E1; [|discriminate]. | ||
| 197 | ec. | ||
| 309 | inversion H; subst. destruct HP as [U1 [HU1 HP1]]. | ||
| 198 | 1: apply I1. | ||
| 310 | eapply evstep_progress_trans. | ||
| 199 | replace (x+3) with (1+(x+2)) by lia. | ||
| 311 | + apply (wpop_spec c U U1 Ew HU1). | ||
| 200 | ec. | ||
| 312 | + eapply IH; eauto. | ||
| 201 | 1: lia. | ||
| 313 | - destruct (lstep c) as [[c1 [|]]|] eqn:E1; [| |discriminate]. | ||
| 202 | rewrite Nat.sub_diag. | ||
| 314 | + inversion H; subst. cbn in HP; subst. | ||
| 203 | replace ((x+1)/2*2+1) with (x+2) by lia. | ||
| 315 | apply progress_base. eapply lstep_spec; eauto. | ||
| 204 | ec. | ||
| 316 | + eapply progress_step. | ||
| 205 | } | ||
| 317 | * eapply lstep_spec; eauto. | ||
| 206 | intros. | ||
| 318 | * eapply IH; eauto. | ||
| 207 | replace a with (1+(a-1)) by lia. | ||
| 208 | assert (a=2\/3<=a) as [E|E] by lia. | ||
| ⋯ 10 template-only lines (template 209–218), not in ours | |||
| 219 | 1: lia. | ||
| 220 | apply I2; lia. | ||
| 221 | Qed. | 319 | Qed. |
| 223 | Lemma Q3_S x: | ||
| 321 | (* ===================================================================== *) | ||
| 224 | 10<=x -> | ||
| 322 | (* 4. The nursery: 8 record types and their window runs (Lemma N). *) | ||
| 225 | Q3 x -> | ||
| 323 | (* ===================================================================== *) | ||
| 226 | Q4 x. | ||
| 325 | Inductive rt := XC | XD | XE | YC | YD | YE | ZD | ZE. | ||
| 327 | Definition rq (t : rt) : Q := | ||
| 328 | match t with | ||
| 329 | | XC | YC => C | ||
| 330 | | XD | YD | ZD => D | ||
| 331 | | XE | YE | ZE => E | ||
| 332 | end. | ||
| 334 | (* the gadget: the first three 1-runs after the head cell and 3 cells *) | ||
| 335 | Definition rg (t : rt) : list Sym := | ||
| 336 | match t with | ||
| 337 | | XC => [1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0] | ||
| 338 | | XD => [1;1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0] | ||
| 339 | | XE => [1;1;1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0] | ||
| 340 | | YC => [1;1;0;1;1;1;1; 0;0;0;0; 1;1; 0;0;0] | ||
| 341 | | YD => [1;1;1;0;1;1;1;1; 0;0;0;0; 1;1; 0;0;0] | ||
| 342 | | YE => [1;1;1;1;0;1;1;1;1; 0;0;0;0; 1;1; 0;0;0] | ||
| 343 | | ZD => [1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0; 1;1;1; 0;0;0] | ||
| 344 | | ZE => [1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0; 1;1;1; 0;0;0] | ||
| 345 | end. | ||
| 347 | Definition rnext (t : rt) : rt := | ||
| 348 | match t with | ||
| 349 | | XC => XD | XD => XE | XE => YC | YC => YD | ||
| 350 | | YD => YE | YE => ZD | ZD => ZE | ZE => XC | ||
| 351 | end. | ||
| 353 | (* W-rule uses (pops) of each window run *) | ||
| 354 | Definition rk (t : rt) : nat := | ||
| 355 | match t with XE => 3 | YE => 12 | ZE => 2 | _ => 0 end. | ||
| 357 | (* the new walls put in front of the unit word *) | ||
| 358 | Definition rF (t : rt) : list unt := | ||
| 359 | match t with | ||
| 360 | | XE => [uW; uW; uP; uSP] | ||
| 361 | | YE => [uW; uP; uW; uP; uP; uSP; uP; uP; uP; uP; uSP] | ||
| 362 | | ZE => [uP; uSP] | ||
| 363 | | _ => [] | ||
| 364 | end. | ||
| 366 | (* the configuration at a left record: 0^inf <q G U 0^inf *) | ||
| 367 | Definition rcfg (t : rt) (U : list unt) : Q * tape := | ||
| 368 | const 0 <{{rq t}} rg t *> Rs U. | ||
| 370 | Lemma window_gen t U U' : | ||
| 371 | wrun 4000 ([], 0, rg t, rq t) = Some (([], 0, rg (rnext t) ++ enc (rF t), rq (rnext t)), rk t) -> | ||
| 372 | Pops (rk t) U U' -> rcfg t U -->+ rcfg (rnext t) (rF t ++ U'). | ||
| 227 | Proof. | 373 | Proof. |
| 228 | unfold Q3,Q4. | ||
| 374 | intros H HP. | ||
| 229 | intros Hx [I1 I2]. | ||
| 375 | pose proof (wrun_spec _ _ _ _ H U U' HP) as G. | ||
| 230 | split. | ||
| 376 | unfold rcfg. rewrite Rs_app, <- Str_app_assoc. | ||
| 231 | 1: ec; apply I1. | ||
| 377 | exact G. | ||
| 232 | intros. | ||
| 233 | replace a with (1+(a-1)) by lia. | ||
| ⋯ 11 template-only lines (template 234–244), not in ours | |||
| 245 | 1: lia. | ||
| 246 | apply I2; lia. | ||
| 247 | Qed. | 378 | Qed. |
| 249 | Lemma Q4_S x: | ||
| 380 | Lemma window t U U' : Pops (rk t) U U' -> rcfg t U -->+ rcfg (rnext t) (rF t ++ U'). | ||
| 250 | 10<=x -> | ||
| 251 | Q4 x -> | ||
| 252 | Q1 x (x+5). | ||
| 253 | Proof. | 381 | Proof. |
| 254 | unfold Q1,Q4. | ||
| 382 | apply window_gen. destruct t; vm_compute; reflexivity. | ||
| 255 | intros Hx [I1 I2]. | ||
| 256 | intros. | ||
| ⋯ 22 template-only lines (template 257–278), not in ours | |||
| 279 | 1: lia. | ||
| 280 | apply I2; lia. | ||
| 281 | Qed. | 383 | Qed. |
| 283 | Ltac flia := repeat (lia||f_equal). | ||
| 385 | (* ===================================================================== *) | ||
| 285 | Lemma Q1_S' x: | ||
| 386 | (* 5. The initial segment: 203,465 steps to the first X record. *) | ||
| 286 | 10<=x -> | ||
| 387 | (* ===================================================================== *) | ||
| 287 | Q1 x (x*2) -> | ||
| 389 | Definition U0 : list unt := | ||
| 288 | Q2 (x*2-1). | ||
| 390 | [uP; uSP; uP; uW; uP; uP; uP; uSP; uP; uP; uP; uP; uW; | ||
| 391 | uP; uP; uP; uP; uP; uP; uP; uW; | ||
| 392 | uP; uP; uP; uP; uP; uP; uP; uP; uP; uP; uP; uW; | ||
| 393 | uP; uP; uP; uP; uP; uP; uP; uP; uP; uP; | ||
| 394 | uD0; uD0; uD1; uD1; uD1; uD1]. | ||
| 396 | Lemma init : c0 -->* rcfg XC U0. | ||
| 289 | Proof. | 397 | Proof. |
| 290 | unfold Q1,Q2. | ||
| 398 | change (rcfg XC U0) with (cconfig_to_config ([], rg XC ++ enc U0, 0, C)). | ||
| 291 | intros Hx I2. | ||
| 399 | rewrite c0_to_cconfig. | ||
| 292 | split. | ||
| 400 | apply cconfig_evstep_dec_spec with (n := 1000000). | ||
| 293 | 1:{ | ||
| 401 | vm_compute. reflexivity. | ||
| 294 | replace ((x*2-1+1)/2) with (1+(x-1)) by lia. | ||
| 295 | ec. | ||
| ⋯ 20 template-only lines (template 296–315), not in ours | |||
| 316 | ec. | ||
| 317 | applys_eq P3; flia. | ||
| 318 | Qed. | 402 | Qed. |
| 320 | Definition Q0 x := | ||
| 404 | (* ===================================================================== *) | ||
| 321 | Q2 x /\ Q3 x /\ Q4 x /\ | ||
| 405 | (* 6. Reduction to the unit-word dynamics. *) | ||
| 322 | (forall s, x+5<=s<=x*2 -> Q1 x s). | ||
| 406 | (* ===================================================================== *) | ||
| 324 | Lemma Q2_Q0 x: | ||
| 408 | Inductive Reach : rt -> list unt -> Prop := | ||
| 325 | 10<=x -> | ||
| 409 | | Reach0 : Reach XC U0 | ||
| 326 | x mod 2 = 1 -> | ||
| 410 | | ReachS t U U' : Reach t U -> Pops (rk t) U U' -> Reach (rnext t) (rF t ++ U'). | ||
| 327 | Q2 x -> | ||
| 412 | Definition AbsDefined : Prop := forall t U, Reach t U -> exists U', Pops (rk t) U U'. | ||
| 328 | Q0 x. | ||
| 414 | Lemma nonhalt_of_abs : AbsDefined -> ~ halts tm c0. | ||
| 329 | Proof. | 415 | Proof. |
| 330 | unfold Q0. | ||
| 416 | intros H. | ||
| 331 | intros Hx Hx0 HQ2. | ||
| 417 | eapply multistep_nonhalt; [apply init|]. | ||
| 332 | split. | ||
| 418 | apply (progress_nonhalt_cond tm (rt * list unt) (XC, U0) | ||
| 333 | 1: apply HQ2. | ||
| 419 | (fun p => rcfg (fst p) (snd p)) (fun p => Reach (fst p) (snd p))). | ||
| 334 | epose proof HQ2 as HQ3. | ||
| 420 | - intros [t U] HR. cbn in HR. destruct (H t U HR) as [U' HP]. | ||
| 335 | apply Q2_S in HQ3. | ||
| 421 | exists (rnext t, rF t ++ U'). split. | ||
| 336 | 2,3: lia. | ||
| 422 | + apply window; auto. | ||
| 337 | split. | ||
| 423 | + econstructor; eauto. | ||
| 338 | 1: apply HQ3. | ||
| 424 | - constructor. | ||
| 339 | epose proof HQ3 as HQ4. | ||
| 340 | apply Q3_S in HQ4. | ||
| ⋯ 11 template-only lines (template 341–351), not in ours | |||
| 352 | 2,3: lia. | ||
| 353 | apply IHs; lia. | ||
| 354 | Qed. | 425 | Qed. |
| 356 | Lemma Q0_S x: | ||
| 427 | (* ===================================================================== *) | ||
| 357 | 10<=x -> | ||
| 428 | (* 7. Carry library: n carries (IncN), P transparency, digit counters, *) | ||
| 358 | x mod 2 = 1 -> | ||
| 429 | (* Lemma C1. *) | ||
| 359 | Q0 x -> | ||
| 430 | (* ===================================================================== *) | ||
| 360 | Q0 (x*2-1). | ||
| 432 | Inductive IncN : nat -> list unt -> list unt -> Prop := | ||
| 433 | | IncN_0 w : IncN 0 w w | ||
| 434 | | IncN_S n w w1 w2 : Inc w w1 -> IncN n w1 w2 -> IncN (S n) w w2. | ||
| 436 | Lemma IncN_1 w w' : Inc w w' -> IncN 1 w w'. | ||
| 437 | Proof. intros H. econstructor; eauto. constructor. Qed. | ||
| 439 | Lemma IncN_1_inv w w' : IncN 1 w w' -> Inc w w'. | ||
| 440 | Proof. intros H. inversion H as [|n w0 w1 w2 Hi Hn]; subst. inversion Hn; subst. auto. Qed. | ||
| 442 | Lemma IncN_add a b w w1 w2 : IncN a w w1 -> IncN b w1 w2 -> IncN (a + b) w w2. | ||
| 443 | Proof. induction 1; intros; cbn; auto. econstructor; eauto. Qed. | ||
| 445 | Lemma IncN_split a b w w2 : IncN (a + b) w w2 -> exists w1, IncN a w w1 /\ IncN b w1 w2. | ||
| 361 | Proof. | 446 | Proof. |
| 362 | intros Hx Hx0 HQ0. | ||
| 447 | revert w; induction a as [|a IH]; intros w H; cbn in H. | ||
| 363 | apply Q2_Q0. | ||
| 448 | - exists w. split; [constructor|auto]. | ||
| 364 | 1,2: lia. | ||
| 449 | - inversion H as [|n' w' wa wb Hi Hn]; subst. destruct (IH _ Hn) as [w3 [H5 H6]]. | ||
| 365 | apply Q1_S'. | ||
| 450 | exists w3. split; auto. econstructor; eauto. | ||
| 366 | 1: lia. | ||
| 367 | apply HQ0; lia. | ||
| 368 | Qed. | 451 | Qed. |
| 370 | Ltac solve_v1 := | ||
| 453 | Lemma IncN_det n w a b : IncN n w a -> IncN n w b -> a = b. | ||
| 371 | solve[cbn; ec; solve_v1]. | ||
| 373 | Ltac invs := | ||
| ⋯ 6 template-only lines (template 374–379), not in ours | |||
| 381 | Lemma Q1_O: | ||
| 382 | Q1 10 13. | ||
| 383 | Proof. | 454 | Proof. |
| 384 | unfold Q1. | ||
| 455 | intros H; revert b; induction H as [|n w w1 w2 Hi Hn IH]; intros b Hb; | ||
| 385 | intros. | ||
| 456 | inversion Hb as [|n' w' wa wb Hi' Hn']; subst; auto. | ||
| 386 | destruct a; [invs |]. | ||
| 457 | assert (w1 = wa) by (eapply Inc_det; eauto). subst. auto. | ||
| 387 | destruct a; [invs |]. | ||
| 458 | Qed. | ||
| 388 | destruct a; [invs |]. | ||
| 460 | Lemma IncN_snoc n w w1 w2 : IncN n w w1 -> Inc w1 w2 -> IncN (S n) w w2. | ||
| 389 | destruct a; [invs |]. | ||
| 390 | destruct a; [invs |]. | ||
| ⋯ 10 template-only lines (template 391–400), not in ours | |||
| 402 | Lemma Q0_O: | ||
| 403 | Q0 19. | ||
| 404 | Proof. | 461 | Proof. |
| 405 | apply Q2_Q0. | ||
| 462 | intros H1 H2. replace (S n) with (n + 1) by lia. | ||
| 406 | 1,2: lia. | ||
| 463 | eapply IncN_add; eauto. apply IncN_1; auto. | ||
| 407 | apply (Q1_S' 10); try lia. | ||
| 408 | do 7 (apply Q1_S; try lia; cbn). | ||
| 409 | apply Q1_O. | ||
| 410 | Qed. | 464 | Qed. |
| 412 | Lemma Q0_n i: | ||
| 466 | (* P is transparent *) | ||
| 413 | Q0 (2^i*18+1). | ||
| 467 | Lemma IncN_P n w w' : IncN n w w' -> IncN n (uP :: w) (uP :: w'). | ||
| 468 | Proof. induction 1; econstructor; eauto. constructor; auto. Qed. | ||
| 470 | Lemma IncN_P_inv n w x : IncN n (uP :: w) x -> exists w', x = uP :: w' /\ IncN n w w'. | ||
| 414 | Proof. | 471 | Proof. |
| 415 | induction i. | ||
| 472 | revert w; induction n as [|n IH]; intros w H; inversion H; subst. | ||
| 416 | 1: apply Q0_O. | ||
| 473 | - exists w; split; [auto|constructor]. | ||
| 417 | cbn[Nat.pow]. | ||
| 474 | - match goal with Hi : Inc (uP :: w) ?y, Hn : IncN n ?y x |- _ => | ||
| 418 | apply Q0_S in IHi; try lia. | ||
| 475 | inversion Hi; subst; destruct (IH _ Hn) as [w'' [E H']]; subst end. | ||
| 419 | applys_eq IHi; flia. | ||
| 476 | eexists. split; [reflexivity|]. econstructor; eauto. | ||
| 420 | Qed. | 477 | Qed. |
| 422 | Lemma pow2_ge i: | ||
| 479 | Fixpoint Ps (a : nat) : list unt := match a with O => [] | S a' => uP :: Ps a' end. | ||
| 423 | 2^i>=i+1. | ||
| 481 | Lemma IncN_Ps a n w w' : IncN n w w' -> IncN n (Ps a ++ w) (Ps a ++ w'). | ||
| 482 | Proof. induction a; cbn; auto. intros H. apply IncN_P; auto. Qed. | ||
| 484 | (* one digit: t carries on a digit b pass (b + t) / 2 carries up *) | ||
| 485 | Definition dig (b : nat) : unt := if Nat.eqb (Nat.modulo b 2) O then uD0 else uD1. | ||
| 486 | Definition dval (u : unt) : nat := match u with uD1 => 1 | _ => 0 end. | ||
| 487 | Definition isdig (u : unt) : bool := match u with uD0 | uD1 => true | _ => false end. | ||
| 489 | Lemma IncN_digit t u w w' : isdig u = true -> IncN ((dval u + t) / 2) w w' -> | ||
| 490 | IncN t (u :: w) (dig (dval u + t) :: w'). | ||
| 424 | Proof. | 491 | Proof. |
| 425 | induction i; cbn[Nat.pow]; lia. | ||
| 492 | revert u w w'. induction t as [t IH] using lt_wf_ind. intros u w w' Hu H. | ||
| 493 | destruct t as [|[|t]]. | ||
| 494 | - destruct u; try discriminate; cbn in *; inversion H; subst; constructor. | ||
| 495 | - destruct u; try discriminate; cbn in *. | ||
| 496 | + inversion H; subst. apply IncN_1. constructor. | ||
| 497 | + apply IncN_1. apply IncN_1_inv in H. constructor; auto. | ||
| 498 | - (* two carries first *) | ||
| 499 | destruct u; try discriminate. | ||
| 500 | + (* D0: D0 -> D1 -> D0 + one carry *) | ||
| 501 | replace ((dval uD0 + S (S t)) / 2) with (1 + (dval uD0 + t) / 2) in H. | ||
| 502 | 2:{ cbn [dval]. rewrite !Nat.add_0_l. replace (S (S t)) with (t + 1 * 2)%nat by lia. | ||
| 503 | rewrite Nat.div_add by lia. lia. } | ||
| 504 | destruct (IncN_split _ _ _ _ H) as [w1 [H1 H2]]. | ||
| 505 | apply IncN_1_inv in H1. | ||
| 506 | replace (S (S t)) with (2 + t) by lia. | ||
| 507 | eapply IncN_add. | ||
| 508 | * econstructor; [constructor|]. econstructor; [constructor; eauto|]. constructor. | ||
| 509 | * replace (dig (dval uD0 + (2 + t))) with (dig (dval uD0 + t)). | ||
| 510 | { apply IH; try lia; auto. } | ||
| 511 | unfold dig. cbn [dval]. f_equal. | ||
| 512 | replace (O + (2 + t))%nat with (t + 1 * 2)%nat by lia. rewrite Nat.Div0.mod_add. reflexivity. | ||
| 513 | + (* D1: D1 -> D0 + carry -> D1 *) | ||
| 514 | replace ((dval uD1 + S (S t)) / 2) with (1 + (dval uD1 + t) / 2) in H. | ||
| 515 | 2:{ cbn [dval]. replace (1 + S (S t))%nat with ((1 + t) + 1 * 2)%nat by lia. | ||
| 516 | rewrite Nat.div_add by lia. lia. } | ||
| 517 | destruct (IncN_split _ _ _ _ H) as [w1 [H1 H2]]. | ||
| 518 | apply IncN_1_inv in H1. | ||
| 519 | replace (S (S t)) with (2 + t) by lia. | ||
| 520 | eapply IncN_add. | ||
| 521 | * econstructor; [constructor; eauto|]. econstructor; [constructor|]. constructor. | ||
| 522 | * replace (dig (dval uD1 + (2 + t))) with (dig (dval uD1 + t)). | ||
| 523 | { apply IH; try lia; auto. } | ||
| 524 | unfold dig. cbn [dval]. f_equal. | ||
| 525 | replace (1 + (2 + t))%nat with ((1 + t) + 1 * 2)%nat by lia. rewrite Nat.Div0.mod_add. reflexivity. | ||
| 526 | Qed. | ||
| 528 | (* walls: SP (state 0, absorbs the next carry) and W (state 1, fires) *) | ||
| 529 | Definition wallu (b : bool) : unt := if b then uW else uSP. | ||
| 531 | Lemma Inc_SP_W r : Inc (uSP :: r) (uW :: r). | ||
| 532 | Proof. constructor. Qed. | ||
| 534 | (* a firing: three carries on the rest, then the shift lands on its first unit, a P *) | ||
| 535 | Lemma Inc_W_fire r r' : Inc3Pop r r' -> Inc (uW :: r) (uP :: uSP :: r'). | ||
| 536 | Proof. | ||
| 537 | intros [a [b [H1 [H2 H3]]]]. eapply Inc_W; eauto. | ||
| 538 | Qed. | ||
| 540 | Lemma Pops_add a b U U1 U2 : Pops a U U1 -> Pops b U1 U2 -> Pops (a + b) U U2. | ||
| 541 | Proof. | ||
| 542 | revert U; induction a as [|a IH]; intros U H1 H2; cbn in *. | ||
| 543 | - subst; auto. | ||
| 544 | - destruct H1 as [V [HV H1]]. exists V. split; [auto|eapply IH; eauto]. | ||
| 545 | Qed. | ||
| 547 | Lemma Pops_split a b U U2 : Pops (a + b) U U2 -> exists U1, Pops a U U1 /\ Pops b U1 U2. | ||
| 548 | Proof. | ||
| 549 | revert U; induction a as [|a IH]; intros U H; cbn in *. | ||
| 550 | - exists U. split; auto. | ||
| 551 | - destruct H as [V [HV H]]. destruct (IH _ H) as [U1 [H1 H2]]. | ||
| 552 | exists U1. split; auto. exists V. auto. | ||
| 553 | Qed. | ||
| 555 | (* the rotor: t carries on a wall in state b fire it (t + b) / 2 times *) | ||
| 556 | Lemma wall_feed t (b : bool) r r' : | ||
| 557 | Pops ((t + Nat.b2n b) / 2) r r' -> | ||
| 558 | IncN t (wallu b :: r) (Ps ((t + Nat.b2n b) / 2) ++ wallu (Nat.odd (t + Nat.b2n b)) :: r'). | ||
| 559 | Proof. | ||
| 560 | revert b r r'. induction t as [t IH] using lt_wf_ind. intros b r r' H. | ||
| 561 | destruct b. | ||
| 562 | - (* W *) | ||
| 563 | destruct t as [|t]. | ||
| 564 | + cbn in *. subst. constructor. | ||
| 565 | + replace ((S t + Nat.b2n true) / 2) with (1 + (t + Nat.b2n false) / 2) in *. | ||
| 566 | 2:{ cbn [Nat.b2n]. replace (S t + 1) with (t + 0 + 1 * 2) by lia. | ||
| 567 | rewrite Nat.div_add by lia. lia. } | ||
| 568 | destruct (Pops_split _ _ _ _ H) as [r1 [H1 H2]]. | ||
| 569 | cbn in H1. destruct H1 as [V [HV E]]. subst V. | ||
| 570 | econstructor. | ||
| 571 | * apply Inc_W_fire. eauto. | ||
| 572 | * assert (E : forall x y, Ps (1 + x) ++ y = uP :: (Ps x ++ y)) by reflexivity. | ||
| 573 | rewrite E. apply IncN_P. | ||
| 574 | replace (Nat.odd (S t + Nat.b2n true)) with (Nat.odd (t + Nat.b2n false)). | ||
| 575 | { exact (IH t ltac:(lia) false r1 r' H2). } | ||
| 576 | cbn [Nat.b2n]. replace (S t + 1) with (S (S (t + 0))) by lia. | ||
| 577 | rewrite Nat.odd_succ_succ. reflexivity. | ||
| 578 | - (* SP *) | ||
| 579 | destruct t as [|t]. | ||
| 580 | + cbn in *. subst. constructor. | ||
| 581 | + replace ((S t + Nat.b2n false) / 2) with ((t + Nat.b2n true) / 2) in *. | ||
| 582 | 2:{ cbn [Nat.b2n]. f_equal. lia. } | ||
| 583 | econstructor. | ||
| 584 | * apply Inc_SP_W. | ||
| 585 | * replace (Nat.odd (S t + Nat.b2n false)) with (Nat.odd (t + Nat.b2n true)). | ||
| 586 | { apply (IH t ltac:(lia) true). auto. } | ||
| 587 | cbn [Nat.b2n]. f_equal. lia. | ||
| 588 | Qed. | ||
| 590 | (* Lemma C1: three carries turn a first unit P, S1, SP or W into P *) | ||
| 591 | Lemma C1 u r x : In u [uP; uS1; uSP; uW] -> IncN 3 (u :: r) x -> exists x', x = uP :: x'. | ||
| 592 | Proof. | ||
| 593 | intros Hu H. | ||
| 594 | destruct Hu as [<-|[<-|[<-|[<-|[]]]]]. | ||
| 595 | - apply IncN_P_inv in H. destruct H as [w' [E _]]. eauto. | ||
| 596 | - inversion H as [|n w w1 w2 Hi Hn]; subst. inversion Hi; subst. | ||
| 597 | apply IncN_P_inv in Hn. destruct Hn as [w' [E _]]. eauto. | ||
| 598 | - inversion H as [|n w w1 w2 Hi Hn]; subst. inversion Hi; subst. | ||
| 599 | inversion Hn as [|n' w' wa wb Hi' Hn']; subst. inversion Hi'; subst. | ||
| 600 | apply IncN_P_inv in Hn'. destruct Hn' as [w'' [E _]]. eauto. | ||
| 601 | - inversion H as [|n w w1 w2 Hi Hn]; subst. inversion Hi; subst. | ||
| 602 | apply IncN_P_inv in Hn. destruct Hn as [w' [E _]]. eauto. | ||
| 603 | Qed. | ||
| 605 | (* r binary digits of v, least significant first *) | ||
| 606 | Fixpoint digits (r v : nat) : list unt := | ||
| 607 | match r with | ||
| 608 | | O => [] | ||
| 609 | | S r' => dig v :: digits r' (v / 2) | ||
| 610 | end. | ||
| 612 | Lemma dval_dig v : dval (dig v) = v mod 2. | ||
| 613 | Proof. | ||
| 614 | unfold dig. destruct (Nat.eqb_spec (v mod 2) 0) as [E|E]; cbn [dval]; [lia|]. | ||
| 615 | pose proof (Nat.mod_upper_bound v 2). lia. | ||
| 616 | Qed. | ||
| 618 | Lemma isdig_dig v : isdig (dig v) = true. | ||
| 619 | Proof. unfold dig. destruct (Nat.eqb (v mod 2) 0); reflexivity. Qed. | ||
| 621 | Lemma dig_mod v : dig (v mod 2) = dig v. | ||
| 622 | Proof. unfold dig. rewrite Nat.Div0.mod_mod. reflexivity. Qed. | ||
| 624 | (* t carries on an r-digit counter pass ((v mod 2^r) + t) / 2^r carries up *) | ||
| 625 | Lemma IncN_digits r v t rest rest' : | ||
| 626 | IncN ((v mod 2 ^ r + t) / 2 ^ r) rest rest' -> | ||
| 627 | IncN t (digits r v ++ rest) (digits r (v + t) ++ rest'). | ||
| 628 | Proof. | ||
| 629 | revert v t. induction r as [|r IH]; intros v t H. | ||
| 630 | - cbn [digits app]. replace ((v mod 2 ^ 0 + t) / 2 ^ 0) with t in H; [auto|]. | ||
| 631 | rewrite Nat.pow_0_r, Nat.mod_1_r, Nat.div_1_r. lia. | ||
| 632 | - cbn [digits app]. | ||
| 633 | assert (Ev : v = 2 * (v / 2) + v mod 2) by (apply Nat.div_mod; lia). | ||
| 634 | assert (E1 : (v + t) / 2 = v / 2 + (v mod 2 + t) / 2). | ||
| 635 | { rewrite Ev at 1. replace (2 * (v / 2) + v mod 2 + t) with ((v mod 2 + t) + (v / 2) * 2) by lia. | ||
| 636 | rewrite Nat.div_add by lia. lia. } | ||
| 637 | replace (dig (v + t)) with (dig (dval (dig v) + t)). | ||
| 638 | 2:{ rewrite dval_dig. rewrite <- dig_mod, <- (dig_mod (v + t)). f_equal. | ||
| 639 | rewrite Nat.Div0.add_mod_idemp_l. reflexivity. } | ||
| 640 | apply IncN_digit; [apply isdig_dig|]. | ||
| 641 | rewrite E1, dval_dig. apply IH. | ||
| 642 | replace ((v / 2) mod 2 ^ r + (v mod 2 + t) / 2) with ((v mod 2 ^ S r + t) / 2). | ||
| 643 | + rewrite Nat.Div0.div_div. rewrite Nat.pow_succ_r'. exact H. | ||
| 644 | + rewrite Nat.pow_succ_r'. rewrite Nat.Div0.mod_mul_r. | ||
| 645 | replace (v mod 2 + 2 * ((v / 2) mod 2 ^ r) + t) with ((v mod 2 + t) + ((v / 2) mod 2 ^ r) * 2) by lia. | ||
| 646 | rewrite Nat.div_add by lia. lia. | ||
| 647 | Qed. | ||
| 649 | (* ===================================================================== *) | ||
| 650 | (* 8. The closed zone system (proof.md section 5). *) | ||
| 651 | (* ===================================================================== *) | ||
| 653 | Definition notP (w : list unt) : Prop := match w with uP :: _ => False | _ => True end. | ||
| 655 | Definition pj (j : nat) : nat := nth (j mod 8) [47; 48; 48; 47; 48; 47; 48; 47] 47. | ||
| 657 | (* one step: feed c = D + p(j) carries, every leading P is dropped and adds | ||
| 658 | 3 carries, stop at the least fixed point m = c + 3 A(m), then the | ||
| 659 | absorption shift *) | ||
| 660 | Definition cs_step (Z : list unt) (D j : nat) (Z' : list unt) (D' j' : nat) : Prop := | ||
| 661 | exists m A Y, | ||
| 662 | IncN m Z (Ps A ++ Y) /\ notP Y /\ m = D + pj j + 3 * A /\ | ||
| 663 | (forall m' A' Y', m' < m -> IncN m' Z (Ps A' ++ Y') -> notP Y' -> m' <> D + pj j + 3 * A') /\ | ||
| 664 | shift Y = Some Z' /\ D' = D + A /\ j' = S j. | ||
| 666 | Inductive CSreach : list unt -> nat -> nat -> Prop := | ||
| 667 | | CS1 : CSreach [uS1; uD0; uD1; uD1; uD1; uD0; uD1] 0 1 | ||
| 668 | | CSS Z D j Z' D' j' : CSreach Z D j -> cs_step Z D j Z' D' j' -> CSreach Z' D' j'. | ||
| 670 | (* executable carries *) | ||
| 671 | Fixpoint incf (n : nat) (w : list unt) : option (list unt) := | ||
| 672 | match n with | ||
| 673 | | O => None | ||
| 674 | | S n' => | ||
| 675 | match w with | ||
| 676 | | [] => Some [uD1] | ||
| 677 | | uD0 :: w' => Some (uD1 :: w') | ||
| 678 | | uS1 :: w' => Some (uP :: w') | ||
| 679 | | uSP :: w' => Some (uW :: w') | ||
| 680 | | uD1 :: w' => match incf n' w' with Some x => Some (uD0 :: x) | None => None end | ||
| 681 | | uP :: w' => match incf n' w' with Some x => Some (uP :: x) | None => None end | ||
| 682 | | uW :: w' => | ||
| 683 | match incf n' w' with | ||
| 684 | | None => None | ||
| 685 | | Some x1 => | ||
| 686 | match incf n' x1 with | ||
| 687 | | None => None | ||
| 688 | | Some x2 => | ||
| 689 | match incf n' x2 with | ||
| 690 | | None => None | ||
| 691 | | Some x3 => match shift x3 with Some x4 => Some (uP :: x4) | None => None end | ||
| 692 | end | ||
| 693 | end | ||
| 694 | end | ||
| 695 | end | ||
| 696 | end. | ||
| 698 | Lemma incf_sound n w w' : incf n w = Some w' -> Inc w w'. | ||
| 699 | Proof. | ||
| 700 | revert w w'; induction n as [|n IH]; intros w w' H; [discriminate|]. | ||
| 701 | destruct w as [|u w]; cbn in H. | ||
| 702 | - inversion H; constructor. | ||
| 703 | - destruct u. | ||
| 704 | + inversion H; constructor. | ||
| 705 | + destruct (incf n w) eqn:E; inversion H; subst. constructor; auto. | ||
| 706 | + destruct (incf n w) eqn:E; inversion H; subst. constructor; auto. | ||
| 707 | + inversion H; constructor. | ||
| 708 | + inversion H; constructor. | ||
| 709 | + destruct (incf n w) as [x1|] eqn:E1; [|discriminate]. | ||
| 710 | destruct (incf n x1) as [x2|] eqn:E2; [|discriminate]. | ||
| 711 | destruct (incf n x2) as [x3|] eqn:E3; [|discriminate]. | ||
| 712 | destruct (shift x3) as [x4|] eqn:E4; inversion H; subst. | ||
| 713 | eapply Inc_W; eauto. | ||
| 714 | Qed. | ||
| 716 | Fixpoint incNf (fuel k : nat) (w : list unt) : option (list unt) := | ||
| 717 | match k with | ||
| 718 | | O => Some w | ||
| 719 | | S k' => match incf fuel w with Some x => incNf fuel k' x | None => None end | ||
| 720 | end. | ||
| 722 | Lemma incNf_sound fuel k w w' : incNf fuel k w = Some w' -> IncN k w w'. | ||
| 723 | Proof. | ||
| 724 | revert w; induction k as [|k IH]; intros w H; cbn in H. | ||
| 725 | - inversion H; constructor. | ||
| 726 | - destruct (incf fuel w) eqn:E; [|discriminate]. | ||
| 727 | econstructor; [eapply incf_sound; eauto|]. auto. | ||
| 728 | Qed. | ||
| 730 | Fixpoint splitP (w : list unt) : nat * list unt := | ||
| 731 | match w with | ||
| 732 | | uP :: w' => let (a, y) := splitP w' in (S a, y) | ||
| 733 | | _ => (O, w) | ||
| 734 | end. | ||
| 736 | Lemma splitP_spec w : let (a, y) := splitP w in w = Ps a ++ y /\ notP y. | ||
| 737 | Proof. | ||
| 738 | induction w as [|u w IH]; cbn; [split; [reflexivity|exact I]|]. | ||
| 739 | destruct u; try (split; [reflexivity|exact I]). | ||
| 740 | destruct (splitP w) as [a y]. destruct IH as [E N]. subst. split; auto. | ||
| 741 | Qed. | ||
| 743 | Lemma Ps_notP_inj a b x y : Ps a ++ x = Ps b ++ y -> notP x -> notP y -> a = b /\ x = y. | ||
| 744 | Proof. | ||
| 745 | revert b; induction a as [|a IH]; intros [|b] E Nx Ny; cbn in *. | ||
| 746 | - auto. | ||
| 747 | - subst. contradiction. | ||
| 748 | - subst. contradiction. | ||
| 749 | - inversion E. destruct (IH b H0 Nx Ny). auto. | ||
| 750 | Qed. | ||
| 752 | (* leading P units are never lost *) | ||
| 753 | Lemma IncN_Ps_inv k a y x : IncN k (Ps a ++ y) x -> exists y', x = Ps a ++ y' /\ IncN k y y'. | ||
| 754 | Proof. | ||
| 755 | revert x; induction a as [|a IH]; intros x H; cbn in *. | ||
| 756 | - eauto. | ||
| 757 | - apply IncN_P_inv in H. destruct H as [w' [E H]]. subst. | ||
| 758 | destruct (IH _ H) as [y' [E2 H2]]. subst. eauto. | ||
| 759 | Qed. | ||
| 761 | Lemma Ps_prefix_le a b y Y : Ps a ++ y = Ps b ++ Y -> notP Y -> a <= b. | ||
| 762 | Proof. | ||
| 763 | revert b; induction a as [|a IH]; intros [|b] E N; cbn in *; try lia. | ||
| 764 | - subst. contradiction. | ||
| 765 | - inversion E. specialize (IH b H0 N). lia. | ||
| 766 | Qed. | ||
| 768 | (* no fixed point at m' *) | ||
| 769 | Definition NF (Z : list unt) (c m' : nat) : Prop := | ||
| 770 | forall A' Y', IncN m' Z (Ps A' ++ Y') -> notP Y' -> m' <> c + 3 * A'. | ||
| 772 | Fixpoint cs_loop (fuel cf c m : nat) (Zm : list unt) : option (nat * nat * list unt) := | ||
| 773 | match fuel with | ||
| 774 | | O => None | ||
| 775 | | S f => | ||
| 776 | let (a, y) := splitP Zm in | ||
| 777 | if Nat.eqb m (c + 3 * a) then Some (m, a, y) | ||
| 778 | else | ||
| 779 | match incNf cf (c + 3 * a - m) Zm with | ||
| 780 | | Some Zm' => cs_loop f cf c (c + 3 * a) Zm' | ||
| 781 | | None => None | ||
| 782 | end | ||
| 783 | end. | ||
| 785 | Lemma cs_loop_sound fuel cf c Z m Zm m2 A2 Y2 : | ||
| 786 | cs_loop fuel cf c m Zm = Some (m2, A2, Y2) -> | ||
| 787 | IncN m Z Zm -> (forall m', m' < m -> NF Z c m') -> | ||
| 788 | (forall A Y, Zm = Ps A ++ Y -> notP Y -> m <= c + 3 * A) -> | ||
| 789 | IncN m2 Z (Ps A2 ++ Y2) /\ notP Y2 /\ m2 = c + 3 * A2 /\ (forall m', m' < m2 -> NF Z c m'). | ||
| 790 | Proof. | ||
| 791 | revert m Zm; induction fuel as [|f IH]; intros m Zm H HZ HNF Hle; [discriminate|]. | ||
| 792 | cbn [cs_loop] in H. pose proof (splitP_spec Zm) as HS. | ||
| 793 | destruct (splitP Zm) as [A Y]. destruct HS as [EZ NY]. | ||
| 794 | specialize (Hle A Y EZ NY). | ||
| 795 | destruct (Nat.eqb m (c + 3 * A)) eqn:Em; [apply Nat.eqb_eq in Em | apply Nat.eqb_neq in Em]. | ||
| 796 | - inversion H; subst. repeat split; auto. | ||
| 797 | - destruct (incNf cf (c + 3 * A - m) Zm) as [Zm'|] eqn:E; [|discriminate]. | ||
| 798 | apply incNf_sound in E. | ||
| 799 | assert (HZ' : IncN (c + 3 * A) Z Zm'). | ||
| 800 | { replace (c + 3 * A) with (m + (c + 3 * A - m)) by lia. eapply IncN_add; eauto. } | ||
| 801 | eapply IH; eauto. | ||
| 802 | + intros m' Hm' A' Y' H' NY'. | ||
| 803 | destruct (Nat.lt_ge_cases m' m) as [Hlt|Hge]. | ||
| 804 | * apply (HNF m' Hlt A' Y' H' NY'). | ||
| 805 | * (* between m and c + 3A: at least A leading P *) | ||
| 806 | replace m' with (m + (m' - m)) in H' by lia. | ||
| 807 | destruct (IncN_split _ _ _ _ H') as [w1 [Hw1 Hw2]]. | ||
| 808 | assert (w1 = Zm) by (eapply IncN_det; eauto). subst w1. | ||
| 809 | rewrite EZ in Hw2. destruct (IncN_Ps_inv _ _ _ _ Hw2) as [y' [Ey' _]]. | ||
| 810 | pose proof (Ps_prefix_le _ _ _ _ (eq_sym Ey') NY'). lia. | ||
| 811 | + intros A' Y' EZ' NY'. subst Zm'. | ||
| 812 | replace (c + 3 * A) with (m + (c + 3 * A - m)) in HZ' by lia. | ||
| 813 | destruct (IncN_split _ _ _ _ HZ') as [w1 [Hw1 Hw2]]. | ||
| 814 | assert (w1 = Zm) by (eapply IncN_det; eauto). subst w1. | ||
| 815 | rewrite EZ in Hw2. destruct (IncN_Ps_inv _ _ _ _ Hw2) as [y' [Ey' _]]. | ||
| 816 | pose proof (Ps_prefix_le _ _ _ _ (eq_sym Ey') NY'). lia. | ||
| 817 | Qed. | ||
| 819 | Definition csf (fuel cf : nat) (s : list unt * nat * nat) : option (list unt * nat * nat) := | ||
| 820 | let '(z, d, j) := s in | ||
| 821 | match incNf cf (d + pj j) z with | ||
| 822 | | None => None | ||
| 823 | | Some zc => | ||
| 824 | match cs_loop fuel cf (d + pj j) (d + pj j) zc with | ||
| 825 | | None => None | ||
| 826 | | Some (m, a, y) => | ||
| 827 | match shift y with | ||
| 828 | | Some z' => Some (z', d + a, S j) | ||
| 829 | | None => None | ||
| 830 | end | ||
| 831 | end | ||
| 832 | end. | ||
| 834 | Lemma csf_sound fuel cf Z D j Z' D' j' : | ||
| 835 | csf fuel cf (Z, D, j) = Some (Z', D', j') -> cs_step Z D j Z' D' j'. | ||
| 836 | Proof. | ||
| 837 | unfold csf. intros H. | ||
| 838 | destruct (incNf cf (D + pj j) Z) as [Zc|] eqn:E1; [|discriminate]. | ||
| 839 | destruct (cs_loop fuel cf (D + pj j) (D + pj j) Zc) as [[[m A] Y]|] eqn:E2; [|discriminate]. | ||
| 840 | destruct (shift Y) as [Z''|] eqn:E3; inversion H; subst. | ||
| 841 | apply incNf_sound in E1. | ||
| 842 | destruct (cs_loop_sound _ _ _ Z _ _ _ _ _ E2 E1) as [H1 [H2 [H3 H4]]]. | ||
| 843 | - intros m' Hm' A' Y' _ _. lia. | ||
| 844 | - intros. lia. | ||
| 845 | - exists m, A, Y. repeat split; auto. | ||
| 846 | intros m' A' Y' Hm' HI HN. apply (H4 m' Hm' A' Y' HI HN). | ||
| 847 | Qed. | ||
| 849 | Fixpoint csiter (n : nat) (s : list unt * nat * nat) : option (list unt * nat * nat) := | ||
| 850 | match n with | ||
| 851 | | O => Some s | ||
| 852 | | S n' => match csf 200 200 s with Some s' => csiter n' s' | None => None end | ||
| 853 | end. | ||
| 855 | Lemma csiter_reach n Z D j Z' D' j' : | ||
| 856 | CSreach Z D j -> csiter n (Z, D, j) = Some (Z', D', j') -> CSreach Z' D' j'. | ||
| 857 | Proof. | ||
| 858 | revert Z D j; induction n as [|n IH]; intros Z D j HR H; cbn [csiter] in H. | ||
| 859 | - inversion H; subst; auto. | ||
| 860 | - destruct (csf 200 200 (Z, D, j)) as [[[Z1 D1] j1]|] eqn:E; [|discriminate]. | ||
| 861 | eapply IH; [|exact H]. econstructor; [exact HR|]. eapply csf_sound; eauto. | ||
| 862 | Qed. | ||
| 864 | (* the closed system reaches the canonical state C(0) at j = 17 *) | ||
| 865 | Lemma C0_reach : CSreach [uS1; uD0; uD1; uD1; uD1; uD1; uD1] 16 17. | ||
| 866 | Proof. | ||
| 867 | eapply (csiter_reach 16); [constructor|]. | ||
| 868 | vm_compute. reflexivity. | ||
| 869 | Qed. | ||
| 871 | (* ===================================================================== *) | ||
| 872 | (* 9. Pops on conveyor words (used by the record invariant). *) | ||
| 873 | (* ===================================================================== *) | ||
| 875 | Lemma IncN_3_inv w x : IncN 3 w x -> exists a b, Inc w a /\ Inc a b /\ Inc b x. | ||
| 876 | Proof. | ||
| 877 | intros H. | ||
| 878 | inversion H as [|n1 w1 a1 x1 H1 Hn1]; subst. | ||
| 879 | inversion Hn1 as [|n2 w2 a2 x2 H2 Hn2]; subst. | ||
| 880 | inversion Hn2 as [|n3 w3 a3 x3 H3 Hn3]; subst. | ||
| 881 | inversion Hn3; subst. eauto. | ||
| 882 | Qed. | ||
| 884 | Lemma Inc3Pop_of w x : IncN 3 w (uP :: x) -> Inc3Pop w x. | ||
| 885 | Proof. intros H. destruct (IncN_3_inv _ _ H) as [a [b [H1 [H2 H3]]]]. exists a, b. auto. Qed. | ||
| 887 | Lemma IncN_of_Inc3Pop w x : Inc3Pop w x -> IncN 3 w (uP :: x). | ||
| 888 | Proof. | ||
| 889 | intros [a [b [H1 [H2 H3]]]]. | ||
| 890 | econstructor; [eauto|]. econstructor; [eauto|]. econstructor; [eauto|]. constructor. | ||
| 891 | Qed. | ||
| 893 | (* a firing over a wire: three carries pass the first P, which is popped *) | ||
| 894 | Lemma Inc3Pop_P y y3 : IncN 3 y y3 -> Inc3Pop (uP :: y) y3. | ||
| 895 | Proof. intros H. apply Inc3Pop_of. apply IncN_P. auto. Qed. | ||
| 897 | Lemma Pops_Ps k a y y' : IncN (3 * k) y y' -> Pops k (Ps (k + a) ++ y) (Ps a ++ y'). | ||
| 898 | Proof. | ||
| 899 | revert y; induction k as [|k IH]; intros y H; cbn [Pops]. | ||
| 900 | - cbn in *. inversion H; subst. reflexivity. | ||
| 901 | - replace (3 * S k) with (3 + 3 * k) in H by lia. | ||
| 902 | destruct (IncN_split _ _ _ _ H) as [y3 [H3 Hk]]. | ||
| 903 | exists (Ps (k + a) ++ y3). split. | ||
| 904 | + cbn [Ps app]. apply Inc3Pop_P. apply IncN_Ps. auto. | ||
| 905 | + apply IH. auto. | ||
| 906 | Qed. | ||
| 908 | (* a firing directly below a wall: the wall above has moved (Lemma C1) *) | ||
| 909 | Lemma Inc3Pop_wall (b : bool) r r' : | ||
| 910 | Pops ((3 + Nat.b2n b) / 2) r r' -> | ||
| 911 | Inc3Pop (wallu b :: r) (Ps ((3 + Nat.b2n b) / 2 - 1) ++ wallu (Nat.odd (3 + Nat.b2n b)) :: r'). | ||
| 912 | Proof. | ||
| 913 | intros H. apply Inc3Pop_of. | ||
| 914 | pose proof (wall_feed 3 b r r' H) as G. | ||
| 915 | destruct b; cbn in *; exact G. | ||
| 916 | Qed. | ||
| 919 | (* ===================================================================== *) | ||
| 920 | (* 10. Upward flow (Lemma L, item 1): a prefix X that passes e carries *) | ||
| 921 | (* up, with every shift landing inside X, acts on X ++ Y as *) | ||
| 922 | (* X' ++ inc^e(Y). *) | ||
| 923 | (* ===================================================================== *) | ||
| 925 | (* a shift that must land inside X *) | ||
| 926 | Fixpoint shiftX (X : list unt) : option (list unt) := | ||
| 927 | match X with | ||
| 928 | | [] => None | ||
| 929 | | uD0 :: X' => | ||
| 930 | match shiftX X' with | ||
| 931 | | Some X'' => Some (uD0 :: X'') | ||
| 932 | | None => None | ||
| 933 | end | ||
| 934 | | uD1 :: X' => Some (uS1 :: X') | ||
| 935 | | uP :: X' => Some (uSP :: X') | ||
| 936 | | _ => None | ||
| 937 | end. | ||
| 939 | Lemma shiftX_app X X' Y : shiftX X = Some X' -> shift (X ++ Y) = Some (X' ++ Y). | ||
| 940 | Proof. | ||
| 941 | revert X'; induction X as [|u X IH]; intros X' H; cbn in H; [discriminate|]. | ||
| 942 | destruct u; try discriminate. | ||
| 943 | - destruct (shiftX X) as [X''|] eqn:E; [|discriminate]. inversion H; subst. | ||
| 944 | cbn [app shift]. rewrite (IH X'' eq_refl). reflexivity. | ||
| 945 | - inversion H; subst. reflexivity. | ||
| 946 | - inversion H; subst. reflexivity. | ||
| 947 | Qed. | ||
| 949 | Inductive IncX : list unt -> nat -> list unt -> Prop := | ||
| 950 | | IncX_nil : IncX [] 1 [] | ||
| 951 | | IncX_D0 X : IncX (uD0 :: X) 0 (uD1 :: X) | ||
| 952 | | IncX_S1 X : IncX (uS1 :: X) 0 (uP :: X) | ||
| 953 | | IncX_SP X : IncX (uSP :: X) 0 (uW :: X) | ||
| 954 | | IncX_D1 X e X' : IncX X e X' -> IncX (uD1 :: X) e (uD0 :: X') | ||
| 955 | | IncX_P X e X' : IncX X e X' -> IncX (uP :: X) e (uP :: X') | ||
| 956 | | IncX_W X e1 e2 e3 X1 X2 X3 X4 : | ||
| 957 | IncX X e1 X1 -> IncX X1 e2 X2 -> IncX X2 e3 X3 -> shiftX X3 = Some X4 -> | ||
| 958 | IncX (uW :: X) (e1 + e2 + e3) (uP :: X4). | ||
| 960 | Lemma IncX_flow X e X' : IncX X e X' -> | ||
| 961 | forall Y Y', IncN e Y Y' -> Inc (X ++ Y) (X' ++ Y'). | ||
| 962 | Proof. | ||
| 963 | induction 1; intros Y Y' HY; cbn [app]. | ||
| 964 | - apply IncN_1_inv. exact HY. | ||
| 965 | - inversion HY; subst. constructor. | ||
| 966 | - inversion HY; subst. constructor. | ||
| 967 | - inversion HY; subst. constructor. | ||
| 968 | - constructor. auto. | ||
| 969 | - constructor. auto. | ||
| 970 | - rewrite <- Nat.add_assoc in HY. | ||
| 971 | destruct (IncN_split _ _ _ _ HY) as [Y1 [Ha Hbc]]. | ||
| 972 | destruct (IncN_split _ _ _ _ Hbc) as [Y2 [Hb Hc]]. | ||
| 973 | eapply Inc_W. | ||
| 974 | + apply IHIncX1. exact Ha. | ||
| 975 | + apply IHIncX2. exact Hb. | ||
| 976 | + apply IHIncX3. exact Hc. | ||
| 977 | + apply shiftX_app. assumption. | ||
| 978 | Qed. | ||
| 980 | (* n carries on X *) | ||
| 981 | Inductive IncXN : nat -> list unt -> nat -> list unt -> Prop := | ||
| 982 | | IncXN_0 X : IncXN 0 X 0 X | ||
| 983 | | IncXN_S n X e X1 e' X2 : IncX X e X1 -> IncXN n X1 e' X2 -> IncXN (S n) X (e + e') X2. | ||
| 985 | Lemma IncXN_flow n X e X' : IncXN n X e X' -> | ||
| 986 | forall Y Y', IncN e Y Y' -> IncN n (X ++ Y) (X' ++ Y'). | ||
| 987 | Proof. | ||
| 988 | induction 1; intros Y Y' HY. | ||
| 989 | - inversion HY; subst. constructor. | ||
| 990 | - destruct (IncN_split _ _ _ _ HY) as [Y1 [H1 H2]]. | ||
| 991 | econstructor. | ||
| 992 | + eapply IncX_flow; eauto. | ||
| 993 | + apply IHIncXN. exact H2. | ||
| 994 | Qed. | ||
| 996 | (* executable version *) | ||
| 997 | Fixpoint incXf (n : nat) (X : list unt) : option (nat * list unt) := | ||
| 998 | match n with | ||
| 999 | | O => None | ||
| 1000 | | S n' => | ||
| 1001 | match X with | ||
| 1002 | | [] => Some (1%nat, []) | ||
| 1003 | | uD0 :: X' => Some (O, uD1 :: X') | ||
| 1004 | | uS1 :: X' => Some (O, uP :: X') | ||
| 1005 | | uSP :: X' => Some (O, uW :: X') | ||
| 1006 | | uD1 :: X' => match incXf n' X' with Some (e, x) => Some (e, uD0 :: x) | None => None end | ||
| 1007 | | uP :: X' => match incXf n' X' with Some (e, x) => Some (e, uP :: x) | None => None end | ||
| 1008 | | uW :: X' => | ||
| 1009 | match incXf n' X' with | ||
| 1010 | | None => None | ||
| 1011 | | Some (e1, x1) => | ||
| 1012 | match incXf n' x1 with | ||
| 1013 | | None => None | ||
| 1014 | | Some (e2, x2) => | ||
| 1015 | match incXf n' x2 with | ||
| 1016 | | None => None | ||
| 1017 | | Some (e3, x3) => | ||
| 1018 | match shiftX x3 with | ||
| 1019 | | Some x4 => Some (e1 + e2 + e3, uP :: x4) | ||
| 1020 | | None => None | ||
| 1021 | end | ||
| 1022 | end | ||
| 1023 | end | ||
| 1024 | end | ||
| 1025 | end | ||
| 1026 | end. | ||
| 1028 | Lemma incXf_sound n X e X' : incXf n X = Some (e, X') -> IncX X e X'. | ||
| 1029 | Proof. | ||
| 1030 | revert X e X'; induction n as [|n IH]; intros X e X' H; [discriminate|]. | ||
| 1031 | destruct X as [|u X]; cbn [incXf] in H. | ||
| 1032 | - inversion H; constructor. | ||
| 1033 | - destruct u. | ||
| 1034 | + inversion H; constructor. | ||
| 1035 | + destruct (incXf n X) as [[e0 x]|] eqn:E; inversion H; subst. constructor; auto. | ||
| 1036 | + destruct (incXf n X) as [[e0 x]|] eqn:E; inversion H; subst. constructor; auto. | ||
| 1037 | + inversion H; constructor. | ||
| 1038 | + inversion H; constructor. | ||
| 1039 | + destruct (incXf n X) as [[e1 x1]|] eqn:E1; [|discriminate]. | ||
| 1040 | destruct (incXf n x1) as [[e2 x2]|] eqn:E2; [|discriminate]. | ||
| 1041 | destruct (incXf n x2) as [[e3 x3]|] eqn:E3; [|discriminate]. | ||
| 1042 | destruct (shiftX x3) as [x4|] eqn:E4; inversion H; subst. | ||
| 1043 | eapply IncX_W; eauto. | ||
| 1044 | Qed. | ||
| 1046 | Local Open Scope bool_scope. | ||
| 1048 | (* ===================================================================== *) | ||
| 1049 | (* 11. Binary words: bin v (least significant first, no trailing D0). *) | ||
| 1050 | (* ===================================================================== *) | ||
| 1052 | Fixpoint binp (p : positive) : list unt := | ||
| 1053 | match p with | ||
| 1054 | | xH => [uD1] | ||
| 1055 | | xO p' => uD0 :: binp p' | ||
| 1056 | | xI p' => uD1 :: binp p' | ||
| 1057 | end. | ||
| 1059 | Definition binN (n : N) : list unt := match n with N0 => [] | Npos p => binp p end. | ||
| 1061 | Definition bin (v : nat) : list unt := binN (N.of_nat v). | ||
| 1063 | Definition digN (n : N) : unt := | ||
| 1064 | match n with | ||
| 1065 | | N0 => uD0 | ||
| 1066 | | Npos xH => uD1 | ||
| 1067 | | Npos (xO _) => uD0 | ||
| 1068 | | Npos (xI _) => uD1 | ||
| 1069 | end. | ||
| 1071 | Lemma dig_even x : dig (2 * x) = uD0. | ||
| 1072 | Proof. unfold dig. replace (2 * x) with (0 + x * 2) by lia. rewrite Nat.Div0.mod_add. reflexivity. Qed. | ||
| 1074 | Lemma dig_odd x : dig (2 * x + 1) = uD1. | ||
| 1075 | Proof. unfold dig. replace (2 * x + 1) with (1 + x * 2) by lia. rewrite Nat.Div0.mod_add. reflexivity. Qed. | ||
| 1077 | Lemma digN_dig n : digN n = dig (N.to_nat n). | ||
| 1078 | Proof. | ||
| 1079 | destruct n as [|[p|p|]]; cbn [digN]. | ||
| 1080 | - reflexivity. | ||
| 1081 | - change (N.to_nat (Npos (xI p))) with (Pos.to_nat (xI p)). rewrite Pos2Nat.inj_xI. symmetry. replace (S (2 * Pos.to_nat p)) with (2 * Pos.to_nat p + 1) by lia. | ||
| 1082 | apply dig_odd. | ||
| 1083 | - change (N.to_nat (Npos (xO p))) with (Pos.to_nat (xO p)). rewrite Pos2Nat.inj_xO. symmetry. apply dig_even. | ||
| 1084 | - reflexivity. | ||
| 1085 | Qed. | ||
| 1087 | Lemma Inc_binp p : Inc (binp p) (binp (Pos.succ p)). | ||
| 1088 | Proof. | ||
| 1089 | induction p as [p IH|p IH|]; cbn [binp Pos.succ]. | ||
| 1090 | - constructor. exact IH. | ||
| 1091 | - constructor. | ||
| 1092 | - constructor. constructor. | ||
| 1093 | Qed. | ||
| 1095 | Lemma Inc_binN n : Inc (binN n) (binN (N.succ n)). | ||
| 1096 | Proof. destruct n as [|p]; cbn. - constructor. - apply Inc_binp. Qed. | ||
| 1098 | Lemma IncN_binN t n : IncN t (binN n) (binN (n + N.of_nat t)). | ||
| 1099 | Proof. | ||
| 1100 | revert n; induction t as [|t IH]; intros n. | ||
| 1101 | - rewrite N.add_0_r. constructor. | ||
| 1102 | - econstructor; [apply Inc_binN|]. | ||
| 1103 | replace (n + N.of_nat (S t))%N with (N.succ n + N.of_nat t)%N by lia. apply IH. | ||
| 1104 | Qed. | ||
| 1106 | Lemma IncN_bin t v : IncN t (bin v) (bin (v + t)). | ||
| 1107 | Proof. unfold bin. rewrite Nat2N.inj_add. apply IncN_binN. Qed. | ||
| 1109 | Lemma binN_eq n : binN n = if N.eqb n 0 then [] else digN n :: binN (N.div2 n). | ||
| 1110 | Proof. destruct n as [|[p|p|]]; reflexivity. Qed. | ||
| 1112 | Lemma bin_eq v : bin v = if Nat.eqb v 0 then [] else dig v :: bin (v / 2). | ||
| 1113 | Proof. | ||
| 1114 | unfold bin. rewrite binN_eq. destruct v as [|v]; [reflexivity|]. | ||
| 1115 | replace (N.eqb (N.of_nat (S v)) 0) with false by (symmetry; apply N.eqb_neq; lia). cbn [Nat.eqb]. | ||
| 1116 | rewrite digN_dig, Nat2N.id. f_equal. f_equal. | ||
| 1117 | apply N2Nat.inj. rewrite N2Nat.inj_div2, !Nat2N.id, Nat.div2_div. reflexivity. | ||
| 1118 | Qed. | ||
| 1120 | Lemma bin_pos v : 0 < v -> bin v = dig v :: bin (v / 2). | ||
| 1121 | Proof. intros H. rewrite bin_eq. destruct v; [lia|reflexivity]. Qed. | ||
| 1123 | Lemma bin_0 : bin 0 = []. | ||
| 1124 | Proof. reflexivity. Qed. | ||
| 1126 | Lemma IncN_nil_bin t : IncN t [] (bin t). | ||
| 1127 | Proof. pose proof (IncN_bin t 0) as H. exact H. Qed. | ||
| 1129 | (* dig and division facts *) | ||
| 1130 | Lemma dig_add_even v s : dig (v + 2 * s) = dig v. | ||
| 1131 | Proof. unfold dig. replace (v + 2 * s) with (v + s * 2) by lia. rewrite Nat.Div0.mod_add. reflexivity. Qed. | ||
| 1133 | Lemma div2_add_even v s : (v + 2 * s) / 2 = v / 2 + s. | ||
| 1134 | Proof. replace (v + 2 * s) with (v + s * 2) by lia. apply Nat.div_add. lia. Qed. | ||
| 1136 | Lemma digits_app_bin n x y : x < 2 ^ n -> 0 < y -> digits n x ++ bin y = bin (x + 2 ^ n * y). | ||
| 1137 | Proof. | ||
| 1138 | revert x y; induction n as [|n IH]; intros x y Hx Hy. | ||
| 1139 | - cbn in *. replace x with 0%nat by lia. f_equal. lia. | ||
| 1140 | - cbn [digits app]. rewrite (bin_pos (x + 2 ^ S n * y)). | ||
| 1141 | 2:{ pose proof (Nat.pow_nonzero 2 (S n)). nia. } | ||
| 1142 | rewrite Nat.pow_succ_r'. | ||
| 1143 | replace (x + 2 * 2 ^ n * y) with (x + 2 * (2 ^ n * y)) by lia. | ||
| 1144 | rewrite dig_add_even, div2_add_even. f_equal. | ||
| 1145 | apply IH; auto. rewrite Nat.pow_succ_r' in Hx. | ||
| 1146 | apply Nat.Div0.div_lt_upper_bound. lia. | ||
| 1147 | Qed. | ||
| 1149 | Lemma bin_ones k q : bin (2 ^ k - 1 + 2 ^ (k + 1) * q) = repeat uD1 k ++ bin (2 * q). | ||
| 1150 | Proof. | ||
| 1151 | induction k as [|k IH]. | ||
| 1152 | - cbn [repeat app]. replace (2 ^ 0 - 1 + 2 ^ (0 + 1) * q) with (2 * q) by (cbn; lia). reflexivity. | ||
| 1153 | - pose proof (Nat.pow_nonzero 2 k). | ||
| 1154 | rewrite bin_pos. | ||
| 1155 | 2:{ rewrite Nat.pow_succ_r'. lia. } | ||
| 1156 | replace (2 ^ S k - 1 + 2 ^ (S k + 1) * q) with (2 * (2 ^ k - 1 + 2 ^ (k + 1) * q) + 1). | ||
| 1157 | 2:{ rewrite !Nat.pow_succ_r', !Nat.pow_add_r. cbn. lia. } | ||
| 1158 | rewrite dig_odd. cbn [repeat app]. f_equal. | ||
| 1159 | rewrite <- IH. f_equal. | ||
| 1160 | replace (2 * (2 ^ k - 1 + 2 ^ (k + 1) * q) + 1) with (1 + (2 ^ k - 1 + 2 ^ (k + 1) * q) * 2) by lia. | ||
| 1161 | rewrite Nat.div_add by lia. reflexivity. | ||
| 1162 | Qed. | ||
| 1164 | (* digit-only words *) | ||
| 1165 | Fixpoint allb (f : unt -> bool) (w : list unt) : bool := | ||
| 1166 | match w with [] => true | u :: w' => f u && allb f w' end. | ||
| 1168 | Fixpoint ndig (X : list unt) : nat := | ||
| 1169 | match X with [] => O | u :: X' => (if isdig u then 1 else 0) + ndig X' end. | ||
| 1171 | Fixpoint val (X : list unt) : nat := | ||
| 1172 | match X with [] => O | u :: X' => if isdig u then dval u + 2 * val X' else val X' end. | ||
| 1174 | Lemma digits_val Xd : allb isdig Xd = true -> Xd = digits (length Xd) (val Xd). | ||
| 1175 | Proof. | ||
| 1176 | induction Xd as [|u Xd IH]; intros H; [reflexivity|]. | ||
| 1177 | cbn [allb] in H. apply andb_prop in H. destruct H as [Hu H]. | ||
| 1178 | cbn [length digits val]. rewrite Hu. | ||
| 1179 | f_equal. | ||
| 1180 | - destruct u; try discriminate; cbn [dval]. | ||
| 1181 | + rewrite Nat.add_0_l. symmetry. apply dig_even. | ||
| 1182 | + rewrite Nat.add_comm. symmetry. apply dig_odd. | ||
| 1183 | - rewrite div2_add_even. replace (dval u / 2) with 0%nat. | ||
| 1184 | + apply IH; auto. | ||
| 1185 | + destruct u; reflexivity. | ||
| 1186 | Qed. | ||
| 1188 | Lemma val_lt Xd : allb isdig Xd = true -> val Xd < 2 ^ length Xd. | ||
| 1189 | Proof. | ||
| 1190 | induction Xd as [|u Xd IH]; intros H; cbn; [lia|]. | ||
| 1191 | apply andb_prop in H. destruct H as [Hu H]. rewrite Hu. | ||
| 1192 | specialize (IH H). assert (dval u <= 1) by (destruct u; cbn; lia). lia. | ||
| 1193 | Qed. | ||
| 1195 | (* ===================================================================== *) | ||
| 1196 | (* 12. Carries through a cut: XN t X e X' says that t carries on X ++ Y *) | ||
| 1197 | (* give X' ++ Y' whenever e carries on Y give Y' (every shift lands *) | ||
| 1198 | (* inside X). *) | ||
| 1199 | (* ===================================================================== *) | ||
| 1201 | Definition XN (t : nat) (X : list unt) (e : nat) (X' : list unt) : Prop := | ||
| 1202 | forall Y Y', IncN e Y Y' -> IncN t (X ++ Y) (X' ++ Y'). | ||
| 1204 | Lemma XN_0 X : XN 0 X 0 X. | ||
| 1205 | Proof. intros Y Y' H. inversion H; subst. constructor. Qed. | ||
| 1207 | Lemma XN_nil t : XN t [] t []. | ||
| 1208 | Proof. intros Y Y' H. exact H. Qed. | ||
| 1210 | Lemma XN_add a b X e1 X1 e2 X2 : XN a X e1 X1 -> XN b X1 e2 X2 -> XN (a + b) X (e1 + e2) X2. | ||
| 1211 | Proof. | ||
| 1212 | intros H1 H2 Y Y' H. destruct (IncN_split _ _ _ _ H) as [Y1 [Ha Hb]]. | ||
| 1213 | eapply IncN_add; [apply H1; exact Ha | apply H2; exact Hb]. | ||
| 1214 | Qed. | ||
| 1216 | Lemma XN_P t X e X' : XN t X e X' -> XN t (uP :: X) e (uP :: X'). | ||
| 1217 | Proof. intros H Y Y' HY. cbn [app]. apply IncN_P. apply H. exact HY. Qed. | ||
| 1219 | Lemma XN_digit t u X e X' : isdig u = true -> XN ((dval u + t) / 2) X e X' -> | ||
| 1220 | XN t (u :: X) e (dig (dval u + t) :: X'). | ||
| 1221 | Proof. intros Hu H Y Y' HY. cbn [app]. apply IncN_digit; auto. Qed. | ||
| 1223 | Lemma XN_S1 t X e X' : XN t X e X' -> XN (S t) (uS1 :: X) e (uP :: X'). | ||
| 1224 | Proof. intros H Y Y' HY. cbn [app]. econstructor; [constructor|]. apply IncN_P. apply H. exact HY. Qed. | ||
| 1226 | Lemma XN_SP t X e X' : XN t (uW :: X) e X' -> XN (S t) (uSP :: X) e X'. | ||
| 1227 | Proof. intros H Y Y' HY. cbn [app]. econstructor; [constructor|]. apply (H Y Y' HY). Qed. | ||
| 1229 | Lemma XN_W t X e1 X1 X2 e2 X3 : XN 3 X e1 X1 -> shiftX X1 = Some X2 -> XN t X2 e2 X3 -> | ||
| 1230 | XN (S t) (uW :: X) (e1 + e2) (uP :: X3). | ||
| 1231 | Proof. | ||
| 1232 | intros H1 Hs H2 Y Y' HY. destruct (IncN_split _ _ _ _ HY) as [Y1 [Ha Hb]]. | ||
| 1233 | specialize (H1 _ _ Ha). destruct (IncN_3_inv _ _ H1) as [a [b [Ha1 [Ha2 Ha3]]]]. | ||
| 1234 | cbn [app]. econstructor. | ||
| 1235 | - eapply Inc_W; [exact Ha1|exact Ha2|exact Ha3|]. apply shiftX_app. exact Hs. | ||
| 1236 | - apply IncN_P. apply H2. exact Hb. | ||
| 1237 | Qed. | ||
| 1239 | (* the executable bulk feed, with N counts *) | ||
| 1240 | Fixpoint xfeed (f : nat) (t : N) (X : list unt) : option (list unt * N) := | ||
| 1241 | match f with | ||
| 1242 | | O => None | ||
| 1243 | | S f' => | ||
| 1244 | if N.eqb t 0 then Some (X, 0%N) else | ||
| 1245 | match X with | ||
| 1246 | | [] => Some ([], t) | ||
| 1247 | | uD0 :: X' => | ||
| 1248 | match xfeed f' (N.div2 t) X' with Some (X'', e) => Some (digN t :: X'', e) | None => None end | ||
| 1249 | | uD1 :: X' => | ||
| 1250 | match xfeed f' (N.div2 (N.succ t)) X' with | ||
| 1251 | | Some (X'', e) => Some (digN (N.succ t) :: X'', e) | None => None end | ||
| 1252 | | uP :: X' => match xfeed f' t X' with Some (X'', e) => Some (uP :: X'', e) | None => None end | ||
| 1253 | | uS1 :: X' => match xfeed f' (N.pred t) X' with Some (X'', e) => Some (uP :: X'', e) | None => None end | ||
| 1254 | | uSP :: X' => xfeed f' (N.pred t) (uW :: X') | ||
| 1255 | | uW :: X' => | ||
| 1256 | match xfeed f' 3 X' with | ||
| 1257 | | Some (X1, e1) => | ||
| 1258 | match shiftX X1 with | ||
| 1259 | | Some X2 => | ||
| 1260 | match xfeed f' (N.pred t) X2 with | ||
| 1261 | | Some (X3, e2) => Some (uP :: X3, (e1 + e2)%N) | ||
| 1262 | | None => None | ||
| 1263 | end | ||
| 1264 | | None => None | ||
| 1265 | end | ||
| 1266 | | None => None | ||
| 1267 | end | ||
| 1268 | end | ||
| 1269 | end. | ||
| 1271 | Lemma xfeed_sound f t X X' e : xfeed f t X = Some (X', e) -> XN (N.to_nat t) X (N.to_nat e) X'. | ||
| 1272 | Proof. | ||
| 1273 | revert t X X' e; induction f as [|f IH]; intros t X X' e H; [discriminate|]. | ||
| 1274 | cbn [xfeed] in H. | ||
| 1275 | destruct (N.eqb t 0) eqn:Et. | ||
| 1276 | { apply N.eqb_eq in Et. subst. inversion H; subst. apply XN_0. } | ||
| 1277 | apply N.eqb_neq in Et. | ||
| 1278 | assert (Ht : N.to_nat t = S (N.to_nat (N.pred t))) by lia. | ||
| 1279 | destruct X as [|u X0]. | ||
| 1280 | { inversion H; subst. apply XN_nil. } | ||
| 1281 | destruct u. | ||
| 1282 | - destruct (xfeed f (N.div2 t) X0) as [[X'' e']|] eqn:E; inversion H; subst. | ||
| 1283 | rewrite digN_dig. | ||
| 1284 | replace (N.to_nat t) with (dval uD0 + N.to_nat t) at 2 by reflexivity. | ||
| 1285 | apply XN_digit; [reflexivity|]. | ||
| 1286 | cbn [dval]. rewrite Nat.add_0_l, <- Nat.div2_div, <- N2Nat.inj_div2. apply IH. exact E. | ||
| 1287 | - destruct (xfeed f (N.div2 (N.succ t)) X0) as [[X'' e']|] eqn:E; inversion H; subst. | ||
| 1288 | rewrite digN_dig, N2Nat.inj_succ. | ||
| 1289 | apply XN_digit; [reflexivity|]. | ||
| 1290 | cbn [dval]. replace (1 + N.to_nat t) with (N.to_nat (N.succ t)) by lia. | ||
| 1291 | rewrite <- Nat.div2_div, <- N2Nat.inj_div2. apply IH. exact E. | ||
| 1292 | - destruct (xfeed f t X0) as [[X'' e']|] eqn:E; inversion H; subst. | ||
| 1293 | apply XN_P. apply IH. exact E. | ||
| 1294 | - destruct (xfeed f (N.pred t) X0) as [[X'' e']|] eqn:E; inversion H; subst. | ||
| 1295 | rewrite Ht. apply XN_S1. apply IH. exact E. | ||
| 1296 | - rewrite Ht. apply XN_SP. apply IH. exact H. | ||
| 1297 | - destruct (xfeed f 3 X0) as [[X1 e1]|] eqn:E1; [|discriminate]. | ||
| 1298 | destruct (shiftX X1) as [X2|] eqn:E2; [|discriminate]. | ||
| 1299 | destruct (xfeed f (N.pred t) X2) as [[X3 e2]|] eqn:E3; inversion H; subst. | ||
| 1300 | rewrite Ht, N2Nat.inj_add. eapply XN_W. | ||
| 1301 | + apply IH in E1. exact E1. | ||
| 1302 | + exact E2. | ||
| 1303 | + apply IH. exact E3. | ||
| 1304 | Qed. | ||
| 1306 | (* ===================================================================== *) | ||
| 1307 | (* 13. Clean words (D0, D1, P only) are counters: the P units pass. *) | ||
| 1308 | (* ===================================================================== *) | ||
| 1310 | Fixpoint fill (X : list unt) (v : nat) : list unt := | ||
| 1311 | match X with | ||
| 1312 | | [] => [] | ||
| 1313 | | u :: X' => if isdig u then dig v :: fill X' (v / 2) else u :: fill X' v | ||
| 1314 | end. | ||
| 1316 | Definition cleanu (u : unt) : bool := match u with uD0 | uD1 | uP => true | _ => false end. | ||
| 1318 | Lemma XN_clean X t : allb cleanu X = true -> | ||
| 1319 | XN t X ((val X + t) / 2 ^ ndig X) (fill X (val X + t)). | ||
| 1320 | Proof. | ||
| 1321 | revert t; induction X as [|u X IH]; intros t H. | ||
| 1322 | - cbn [val ndig fill]. rewrite Nat.pow_0_r, Nat.add_0_l, Nat.div_1_r. apply XN_nil. | ||
| 1323 | - cbn [allb] in H. apply andb_prop in H. destruct H as [Hu H]. | ||
| 1324 | destruct u; try discriminate; cbn [ndig val fill isdig]. | ||
| 1325 | + (* D0 *) | ||
| 1326 | replace (dig (dval uD0 + 2 * val X + t)) with (dig (dval uD0 + t)). | ||
| 1327 | 2:{ replace (dval uD0 + 2 * val X + t) with ((dval uD0 + t) + 2 * val X) by lia. | ||
| 1328 | symmetry. apply dig_add_even. } | ||
| 1329 | replace ((dval uD0 + 2 * val X + t) / 2) with (val X + (dval uD0 + t) / 2). | ||
| 1330 | 2:{ replace (dval uD0 + 2 * val X + t) with ((dval uD0 + t) + 2 * val X) by lia. | ||
| 1331 | rewrite div2_add_even. lia. } | ||
| 1332 | replace ((dval uD0 + 2 * val X + t) / 2 ^ (1 + ndig X)) with ((val X + (dval uD0 + t) / 2) / 2 ^ ndig X). | ||
| 1333 | 2:{ rewrite Nat.pow_add_r, Nat.pow_1_r, <- Nat.Div0.div_div. | ||
| 1334 | replace (dval uD0 + 2 * val X + t) with ((dval uD0 + t) + 2 * val X) by lia. | ||
| 1335 | rewrite div2_add_even. f_equal. lia. } | ||
| 1336 | apply XN_digit; [reflexivity|]. apply IH. exact H. | ||
| 1337 | + (* D1 *) | ||
| 1338 | replace (dig (dval uD1 + 2 * val X + t)) with (dig (dval uD1 + t)). | ||
| 1339 | 2:{ replace (dval uD1 + 2 * val X + t) with ((dval uD1 + t) + 2 * val X) by lia. | ||
| 1340 | symmetry. apply dig_add_even. } | ||
| 1341 | replace ((dval uD1 + 2 * val X + t) / 2) with (val X + (dval uD1 + t) / 2). | ||
| 1342 | 2:{ replace (dval uD1 + 2 * val X + t) with ((dval uD1 + t) + 2 * val X) by lia. | ||
| 1343 | rewrite div2_add_even. lia. } | ||
| 1344 | replace ((dval uD1 + 2 * val X + t) / 2 ^ (1 + ndig X)) with ((val X + (dval uD1 + t) / 2) / 2 ^ ndig X). | ||
| 1345 | 2:{ rewrite Nat.pow_add_r, Nat.pow_1_r, <- Nat.Div0.div_div. | ||
| 1346 | replace (dval uD1 + 2 * val X + t) with ((dval uD1 + t) + 2 * val X) by lia. | ||
| 1347 | rewrite div2_add_even. f_equal. lia. } | ||
| 1348 | apply XN_digit; [reflexivity|]. apply IH. exact H. | ||
| 1349 | + (* P *) | ||
| 1350 | rewrite Nat.add_0_l. apply XN_P. apply IH. exact H. | ||
| 1351 | Qed. | ||
| 1353 | Lemma fill_mod X v s : fill X (v + 2 ^ ndig X * s) = fill X v. | ||
| 1354 | Proof. | ||
| 1355 | revert v; induction X as [|u X IH]; intros v; cbn [fill ndig]; [reflexivity|]. | ||
| 1356 | destruct (isdig u) eqn:Hu. | ||
| 1357 | - rewrite Nat.pow_add_r, Nat.pow_1_r. | ||
| 1358 | replace (v + 2 * 2 ^ ndig X * s) with (v + 2 * (2 ^ ndig X * s)) by lia. | ||
| 1359 | rewrite dig_add_even, div2_add_even, IH. reflexivity. | ||
| 1360 | - rewrite Nat.add_0_l, IH. reflexivity. | ||
| 1361 | Qed. | ||
| 1363 | Lemma div_mod_shift v n s : (v + 2 ^ n * s) / 2 ^ n = v / 2 ^ n + s. | ||
| 1364 | Proof. | ||
| 1365 | pose proof (Nat.pow_nonzero 2 n). | ||
| 1366 | replace (v + 2 ^ n * s) with (v + s * 2 ^ n) by lia. apply Nat.div_add. lia. | ||
| 1367 | Qed. | ||
| 1369 | (* digit heads stay digit heads *) | ||
| 1370 | Definition dhead (w : list unt) : bool := match w with uD0 :: _ | uD1 :: _ => true | _ => false end. | ||
| 1372 | Lemma Inc_dhead w w' : dhead w = true -> Inc w w' -> dhead w' = true. | ||
| 1373 | Proof. intros H Hi. destruct Hi; cbn in *; try discriminate; reflexivity. Qed. | ||
| 1375 | Lemma IncN_dhead n w w' : dhead w = true -> IncN n w w' -> dhead w' = true. | ||
| 1376 | Proof. intros H Hi. induction Hi; auto. apply IHHi. eapply Inc_dhead; eauto. Qed. | ||
| 1378 | Lemma dhead_app X Y : dhead X = true -> dhead (X ++ Y) = true. | ||
| 1379 | Proof. intros H. destruct X as [|[] X]; cbn in *; auto; discriminate. Qed. | ||
| 1381 | Lemma dhead_notP w : dhead w = true -> notP w. | ||
| 1382 | Proof. destruct w as [|[] w]; cbn; auto; discriminate. Qed. | ||
| 1384 | (* ===================================================================== *) | ||
| 1385 | (* 14. One closed-system step through a cut (the locality step). *) | ||
| 1386 | (* Phase 1: the first T0 carries act on X alone (all drops happen *) | ||
| 1387 | (* there); phase 2: the rest; the absorption shift. *) | ||
| 1388 | (* ===================================================================== *) | ||
| 1390 | Lemma cutstep X Y T0 e1 A X1 c e2 X2 D j Z' Y' : | ||
| 1391 | XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true -> | ||
| 1392 | XN (c + 3 * A - T0) X1 e2 X2 -> T0 <= c -> c = D + pj j -> | ||
| 1393 | IncN (e1 + e2) Y Y' -> shift (X2 ++ Y') = Some Z' -> | ||
| 1394 | cs_step (X ++ Y) D j Z' (D + A) (S j). | ||
| 1395 | Proof. | ||
| 1396 | intros H1 Hd H2 HT Hc HY Hs. | ||
| 1397 | destruct (IncN_split _ _ _ _ HY) as [Y1 [HY1 HY2]]. | ||
| 1398 | specialize (H1 _ _ HY1). specialize (H2 _ _ HY2). | ||
| 1399 | assert (Hd2 : dhead (X2 ++ Y') = true). | ||
| 1400 | { eapply IncN_dhead; [|exact H2]. apply dhead_app. exact Hd. } | ||
| 1401 | exists (c + 3 * A), A, (X2 ++ Y'). | ||
| 1402 | split; [|split; [|split; [|split; [|split]]]]. | ||
| 1403 | - replace (c + 3 * A) with (T0 + (c + 3 * A - T0)) by lia. | ||
| 1404 | eapply IncN_add; [exact H1|]. rewrite <- app_assoc. apply IncN_Ps. exact H2. | ||
| 1405 | - apply dhead_notP. exact Hd2. | ||
| 1406 | - lia. | ||
| 1407 | - intros m' A' Y'' Hm Hi HN. | ||
| 1408 | destruct (Nat.lt_ge_cases m' T0) as [Hlt|Hge]; [lia|]. | ||
| 1409 | replace m' with (T0 + (m' - T0)) in Hi by lia. | ||
| 1410 | destruct (IncN_split _ _ _ _ Hi) as [w1 [Hw1 Hw2]]. | ||
| 1411 | assert (w1 = (Ps A ++ X1) ++ Y1) by (eapply IncN_det; eauto). subst w1. | ||
| 1412 | rewrite <- app_assoc in Hw2. | ||
| 1413 | destruct (IncN_Ps_inv _ _ _ _ Hw2) as [y' [Ey' Hy']]. | ||
| 1414 | assert (Hdy : dhead y' = true) by (eapply IncN_dhead; [apply dhead_app; exact Hd|exact Hy']). | ||
| 1415 | destruct (Ps_notP_inj _ _ _ _ Ey' HN (dhead_notP _ Hdy)) as [EA _]. lia. | ||
| 1416 | - exact Hs. | ||
| 1417 | - split; reflexivity. | ||
| 1418 | Qed. | ||
| 1420 | (* ===================================================================== *) | ||
| 1421 | (* 15. Affine families of closed-system states and their runner. *) | ||
| 1422 | (* A family stands for the states, for every u, *) | ||
| 1423 | (* zone X ++ bin (y + ay u), D = D0 + aD u, j = j0 + aD u. *) | ||
| 1424 | (* ===================================================================== *) | ||
| 1426 | Record fam := mkF { fX : list unt; fy : N; fay : N; fD : N; fj : N; faD : N }. | ||
| 1428 | Definition st : Type := (list unt * nat * nat)%type. | ||
| 1430 | Definition fz (F : fam) (u : nat) : st := | ||
| 1431 | (fX F ++ bin (N.to_nat (fy F) + N.to_nat (fay F) * u), | ||
| 1432 | N.to_nat (fD F) + N.to_nat (faD F) * u, | ||
| 1433 | N.to_nat (fj F) + N.to_nat (faD F) * u). | ||
| 1435 | Definition CS (s s' : st) : Prop := | ||
| 1436 | cs_step (fst (fst s)) (snd (fst s)) (snd s) (fst (fst s')) (snd (fst s')) (snd s'). | ||
| 1438 | Inductive CSplus : st -> st -> Prop := | ||
| 1439 | | CSp1 s s' : CS s s' -> CSplus s s' | ||
| 1440 | | CSpS s s1 s' : CS s s1 -> CSplus s1 s' -> CSplus s s'. | ||
| 1442 | Lemma CSplus_trans a b c : CSplus a b -> CSplus b c -> CSplus a c. | ||
| 1443 | Proof. induction 1 as [x y Hs|x y z Hs H1 IH]; intros Hn; [eapply CSpS; eauto|]. eapply CSpS; eauto. Qed. | ||
| 1445 | Lemma CS_j s s' : CS s s' -> snd s' = S (snd s). | ||
| 1446 | Proof. | ||
| 1447 | destruct s as [[z d] j], s' as [[z' d'] j']. unfold CS. cbn. | ||
| 1448 | intros [m [a [y [_ [_ [_ [_ [_ [_ E]]]]]]]]]. exact E. | ||
| 1449 | Qed. | ||
| 1451 | Lemma CSplus_j a b : CSplus a b -> snd a < snd b. | ||
| 1452 | Proof. induction 1 as [x y Hs|x y z Hs H1 IH]; apply CS_j in Hs; lia. Qed. | ||
| 1454 | Definition pjN (j : N) : N := N.of_nat (pj (N.to_nat (j mod 8))). | ||
| 1456 | Lemma pj_mod j : pj j = pj (j mod 8). | ||
| 1457 | Proof. unfold pj. rewrite Nat.Div0.mod_mod. reflexivity. Qed. | ||
| 1459 | Lemma pjN_spec j : N.to_nat (pjN j) = pj (N.to_nat j). | ||
| 1460 | Proof. unfold pjN. rewrite Nat2N.id, N2Nat.inj_mod. rewrite (pj_mod (N.to_nat j)). reflexivity. Qed. | ||
| 1462 | Lemma pj_add8 j a : a mod 8 = O -> forall u, pj (j + a * u) = pj j. | ||
| 1463 | Proof. | ||
| 1464 | intros Ha u. rewrite (pj_mod (j + a * u)), (pj_mod j). f_equal. | ||
| 1465 | apply Nat.Div0.mod_divides in Ha. destruct Ha as [g Hg]. subst a. | ||
| 1466 | replace (j + 8 * g * u) with (j + (g * u) * 8) by lia. apply Nat.Div0.mod_add. | ||
| 1467 | Qed. | ||
| 1469 | Fixpoint valN (X : list unt) : N := | ||
| 1470 | match X with | ||
| 1471 | | [] => 0%N | ||
| 1472 | | u :: X' => if isdig u then (N.of_nat (dval u) + 2 * valN X')%N else valN X' | ||
| 1473 | end. | ||
| 1475 | Lemma valN_spec X : N.to_nat (valN X) = val X. | ||
| 1476 | Proof. | ||
| 1477 | induction X as [|u X IH]; cbn [valN val]; [reflexivity|]. | ||
| 1478 | destruct (isdig u); [|exact IH]. | ||
| 1479 | rewrite N2Nat.inj_add, N2Nat.inj_mul, Nat2N.id, IH. reflexivity. | ||
| 1480 | Qed. | ||
| 1482 | Fixpoint fillN (X : list unt) (v : N) : list unt := | ||
| 1483 | match X with | ||
| 1484 | | [] => [] | ||
| 1485 | | u :: X' => if isdig u then digN v :: fillN X' (N.div2 v) else u :: fillN X' v | ||
| 1486 | end. | ||
| 1488 | Lemma fillN_spec X v : fillN X v = fill X (N.to_nat v). | ||
| 1489 | Proof. | ||
| 1490 | revert v; induction X as [|u X IH]; intros v; cbn; [reflexivity|]. | ||
| 1491 | destruct (isdig u); rewrite IH; [|reflexivity]. | ||
| 1492 | rewrite digN_dig, N2Nat.inj_div2, Nat.div2_div. reflexivity. | ||
| 1493 | Qed. | ||
| 1495 | Fixpoint fnorm (n : nat) (F : fam) : fam := | ||
| 1496 | match n with | ||
| 1497 | | O => F | ||
| 1498 | | S n' => | ||
| 1499 | if N.even (fay F) && N.ltb 0 (fy F) then | ||
| 1500 | fnorm n' (mkF (fX F ++ [digN (fy F)]) (N.div2 (fy F)) (N.div2 (fay F)) (fD F) (fj F) (faD F)) | ||
| 1501 | else F | ||
| 1502 | end. | ||
| 1504 | Lemma fnorm_spec n F u : fz (fnorm n F) u = fz F u. | ||
| 1505 | Proof. | ||
| 1506 | revert F; induction n as [|n IH]; intros F; cbn [fnorm]; [reflexivity|]. | ||
| 1507 | destruct (N.even (fay F) && N.ltb 0 (fy F)) eqn:E; [|reflexivity]. | ||
| 1508 | apply andb_prop in E. destruct E as [Ee Ey]. apply N.ltb_lt in Ey. | ||
| 1509 | rewrite IH. unfold fz. cbn [fX fy fay fD fj faD]. | ||
| 1510 | f_equal. f_equal. | ||
| 1511 | apply N.even_spec in Ee. destruct Ee as [g Hg]. | ||
| 1512 | rewrite <- app_assoc. f_equal. | ||
| 1513 | rewrite (bin_pos (N.to_nat (fy F) + N.to_nat (fay F) * u)) by lia. | ||
| 1514 | rewrite Hg. rewrite !N2Nat.inj_div2, !Nat.div2_div, N2Nat.inj_mul. | ||
| 1515 | replace (N.to_nat (fy F) + N.to_nat 2 * N.to_nat g * u) with (N.to_nat (fy F) + 2 * (N.to_nat g * u)) by (cbn; lia). | ||
| 1516 | rewrite dig_add_even, div2_add_even, digN_dig. | ||
| 1517 | replace (N.to_nat 2 * N.to_nat g / 2) with (N.to_nat g). | ||
| 1518 | - reflexivity. | ||
| 1519 | - replace (N.to_nat 2 * N.to_nat g) with (0 + N.to_nat g * 2) by (cbn; lia). | ||
| 1520 | rewrite Nat.div_add by lia. reflexivity. | ||
| 1521 | Qed. | ||
| 1523 | Definition n3 (a : nat) : N := N.of_nat (3 * a). | ||
| 1525 | Lemma n3_spec a : N.to_nat (n3 a) = 3 * a. | ||
| 1526 | Proof. unfold n3. apply Nat2N.id. Qed. | ||
| 1528 | Definition phase2 (F : fam) (X1 : list unt) (a : nat) : option (list unt * N * N) := | ||
| 1529 | let nd := N.of_nat (ndig X1) in | ||
| 1530 | if allb cleanu X1 then | ||
| 1531 | let v := (valN X1 + n3 a)%N in | ||
| 1532 | Some (fillN X1 v, (v / 2 ^ nd)%N, (fay F + faD F / 2 ^ nd)%N) | ||
| 1533 | else if N.eqb (faD F) 0 then | ||
| 1534 | match xfeed 4000 (n3 a) X1 with | ||
| 1535 | | Some (X2, e2) => Some (X2, e2, fay F) | ||
| 1536 | | None => None | ||
| 1537 | end | ||
| 1538 | else None. | ||
| 1540 | Definition fstep (R : nat) (F : fam) : option fam := | ||
| 1541 | if negb (N.eqb (faD F mod 8) 0) then None else | ||
| 1542 | match xfeed 4000 (fD F + pjN (fj F)) (fX F) with | ||
| 1543 | | None => None | ||
| 1544 | | Some (Xt, e1) => | ||
| 1545 | let (a, X1) := splitP Xt in | ||
| 1546 | if negb (dhead X1) then None else | ||
| 1547 | if negb (N.eqb (faD F mod 2 ^ N.of_nat (ndig X1)) 0) then None else | ||
| 1548 | match phase2 F X1 a with | ||
| 1549 | | None => None | ||
| 1550 | | Some (X2, e2, ay2) => | ||
| 1551 | let y2 := (fy F + e1 + e2)%N in | ||
| 1552 | match shiftX X2 with | ||
| 1553 | | Some X3 => Some (fnorm (R - ndig X3) (mkF X3 y2 ay2 (fD F + N.of_nat a) (N.succ (fj F)) (faD F))) | ||
| 1554 | | None => | ||
| 1555 | if N.eqb ay2 0 && N.eqb (faD F) 0 then | ||
| 1556 | match shift (X2 ++ binN y2) with | ||
| 1557 | | Some Z3 => Some (mkF Z3 0 0 (fD F + N.of_nat a) (N.succ (fj F)) (faD F)) | ||
| 1558 | | None => None | ||
| 1559 | end | ||
| 1560 | else None | ||
| 1561 | end | ||
| 1562 | end | ||
| 1563 | end. | ||
| 1565 | Lemma phase2_sound F X1 a X2 e2 ay2 u : | ||
| 1566 | phase2 F X1 a = Some (X2, e2, ay2) -> | ||
| 1567 | N.to_nat (faD F) mod 2 ^ ndig X1 = O -> | ||
| 1568 | XN (3 * a + N.to_nat (faD F) * u) X1 (N.to_nat e2 + (N.to_nat ay2 - N.to_nat (fay F)) * u) X2 /\ | ||
| 1569 | N.to_nat (fay F) <= N.to_nat ay2. | ||
| 1570 | Proof. | ||
| 1571 | unfold phase2. intros H Hdiv. | ||
| 1572 | destruct (allb cleanu X1) eqn:Ec. | ||
| 1573 | - injection H as <- <- <-. | ||
| 1574 | apply Nat.Div0.mod_divides in Hdiv. destruct Hdiv as [g Hg]. | ||
| 1575 | assert (Hp : N.to_nat (2 ^ N.of_nat (ndig X1)) = 2 ^ ndig X1). | ||
| 1576 | { rewrite N2Nat.inj_pow, Nat2N.id. reflexivity. } | ||
| 1577 | assert (Hg' : N.to_nat (faD F / 2 ^ N.of_nat (ndig X1)) = g). | ||
| 1578 | { rewrite N2Nat.inj_div, Hp, Hg. rewrite Nat.mul_comm, Nat.div_mul; [reflexivity|]. | ||
| 1579 | apply Nat.pow_nonzero. lia. } | ||
| 1580 | split; [|rewrite N2Nat.inj_add; lia]. | ||
| 1581 | rewrite N2Nat.inj_add, Hg'. | ||
| 1582 | replace (N.to_nat (fay F) + g - N.to_nat (fay F)) with g by lia. | ||
| 1583 | rewrite fillN_spec, !N2Nat.inj_div, !Hp, !N2Nat.inj_add, !n3_spec, !valN_spec. | ||
| 1584 | pose proof (XN_clean X1 (3 * a + N.to_nat (faD F) * u) Ec) as G. | ||
| 1585 | rewrite Hg in G. | ||
| 1586 | replace (val X1 + (3 * a + 2 ^ ndig X1 * g * u)) with ((val X1 + 3 * a) + 2 ^ ndig X1 * (g * u)) in G by lia. | ||
| 1587 | rewrite fill_mod, div_mod_shift in G. | ||
| 1588 | rewrite Hg. exact G. | ||
| 1589 | - destruct (N.eqb (faD F) 0) eqn:E0; [|discriminate]. | ||
| 1590 | apply N.eqb_eq in E0. rewrite E0. cbn [N.to_nat]. | ||
| 1591 | destruct (xfeed 4000 (n3 a) X1) as [[X2' e2']|] eqn:Ex; [|discriminate]. | ||
| 1592 | injection H as <- <- <-. | ||
| 1593 | split; [|lia]. | ||
| 1594 | apply xfeed_sound in Ex. rewrite n3_spec in Ex. | ||
| 1595 | replace (3 * a + 0 * u) with (3 * a) by lia. | ||
| 1596 | replace (N.to_nat e2' + (N.to_nat (fay F) - N.to_nat (fay F)) * u) with (N.to_nat e2') by lia. | ||
| 1597 | exact Ex. | ||
| 1598 | Qed. | ||
| 1600 | Lemma if_negb_true A (x y : A) : (if negb true then x else y) = y. | ||
| 1601 | Proof. reflexivity. Qed. | ||
| 1603 | (* PITFALL: [cbn in H] on the unfolded fstep makes Qed hang (kernel conversion); | ||
| 1604 | rewriting with [if_negb_true] is instant. *) | ||
| 1605 | Lemma fstep_sound R F F' : fstep R F = Some F' -> forall u, CS (fz F u) (fz F' u). | ||
| 1606 | Proof. | ||
| 1607 | unfold fstep. intros H u. | ||
| 1608 | destruct (N.eqb (faD F mod 8) 0) eqn:E8; [|discriminate]. rewrite if_negb_true in H. | ||
| 1609 | apply N.eqb_eq in E8. | ||
| 1610 | destruct (xfeed 4000 (fD F + pjN (fj F)) (fX F)) as [[Xt e1]|] eqn:Ex; [|discriminate]. | ||
| 1611 | pose proof (splitP_spec Xt) as HS. destruct (splitP Xt) as [a X1]. | ||
| 1612 | destruct HS as [EXt _]. | ||
| 1613 | destruct (dhead X1) eqn:Ed; [|discriminate]. rewrite if_negb_true in H. | ||
| 1614 | destruct (N.eqb (faD F mod 2 ^ N.of_nat (ndig X1)) 0) eqn:Em; [|discriminate]. rewrite if_negb_true in H. | ||
| 1615 | apply N.eqb_eq in Em. | ||
| 1616 | assert (Hdiv : N.to_nat (faD F) mod 2 ^ ndig X1 = O). | ||
| 1617 | { replace (2 ^ ndig X1) with (N.to_nat (2 ^ N.of_nat (ndig X1))) by (rewrite N2Nat.inj_pow, Nat2N.id; reflexivity). | ||
| 1618 | rewrite <- N2Nat.inj_mod, Em. reflexivity. } | ||
| 1619 | destruct (phase2 F X1 a) as [[[X2 e2] ay2]|] eqn:Ep; [|discriminate]. | ||
| 1620 | destruct (phase2_sound F X1 a X2 e2 ay2 u Ep Hdiv) as [HX2 Hay]. | ||
| 1621 | apply xfeed_sound in Ex. rewrite EXt in Ex. | ||
| 1622 | assert (H8 : N.to_nat (faD F) mod 8 = O). | ||
| 1623 | { replace 8 with (N.to_nat 8) by reflexivity. rewrite <- N2Nat.inj_mod, E8. reflexivity. } | ||
| 1624 | set (aD := N.to_nat (faD F)) in *. | ||
| 1625 | set (D0 := N.to_nat (fD F)). set (j0 := N.to_nat (fj F)). | ||
| 1626 | assert (Hc : N.to_nat (fD F + pjN (fj F)) + aD * u = (D0 + aD * u) + pj (j0 + aD * u)). | ||
| 1627 | { rewrite N2Nat.inj_add, pjN_spec. fold D0 j0. rewrite pj_add8 by exact H8. lia. } | ||
| 1628 | set (y0 := N.to_nat (fy F)) in *. set (ay := N.to_nat (fay F)) in *. | ||
| 1629 | assert (HY : IncN (N.to_nat e1 + (N.to_nat e2 + (N.to_nat ay2 - ay) * u)) | ||
| 1630 | (bin (y0 + ay * u)) (bin (N.to_nat (fy F + e1 + e2) + N.to_nat ay2 * u))). | ||
| 1631 | { replace (N.to_nat (fy F + e1 + e2) + N.to_nat ay2 * u) | ||
| 1632 | with ((y0 + ay * u) + (N.to_nat e1 + (N.to_nat e2 + (N.to_nat ay2 - ay) * u))). | ||
| 1633 | - apply IncN_bin. | ||
| 1634 | - rewrite !N2Nat.inj_add. fold y0. rewrite Nat.mul_sub_distr_r. | ||
| 1635 | assert (ay * u <= N.to_nat ay2 * u) by (apply Nat.mul_le_mono_r; exact Hay). lia. } | ||
| 1636 | assert (Hstep : forall Z', shift (X2 ++ bin (N.to_nat (fy F + e1 + e2) + N.to_nat ay2 * u)) = Some Z' -> | ||
| 1637 | cs_step (fX F ++ bin (y0 + ay * u)) (D0 + aD * u) (j0 + aD * u) Z' | ||
| 1638 | (D0 + aD * u + a) (S (j0 + aD * u))). | ||
| 1639 | { intros Z' Hs. | ||
| 1640 | apply (cutstep (fX F) (bin (y0 + ay * u)) (N.to_nat (fD F + pjN (fj F))) (N.to_nat e1) a X1 | ||
| 1641 | (D0 + aD * u + pj (j0 + aD * u)) (N.to_nat e2 + (N.to_nat ay2 - ay) * u) X2 | ||
| 1642 | (D0 + aD * u) (j0 + aD * u) Z' (bin (N.to_nat (fy F + e1 + e2) + N.to_nat ay2 * u))). | ||
| 1643 | - exact Ex. | ||
| 1644 | - exact Ed. | ||
| 1645 | - replace ((D0 + aD * u + pj (j0 + aD * u)) + 3 * a - N.to_nat (fD F + pjN (fj F))) | ||
| 1646 | with (3 * a + aD * u) by (clear -Hc; lia). | ||
| 1647 | exact HX2. | ||
| 1648 | - clear -Hc. lia. | ||
| 1649 | - reflexivity. | ||
| 1650 | - exact HY. | ||
| 1651 | - exact Hs. } | ||
| 1652 | clear Hdiv H8 Em E8 HY Hc HX2 Hay Ex. | ||
| 1653 | destruct (shiftX X2) as [X3|] eqn:Es. | ||
| 1654 | - inversion H; subst. clear H. unfold CS. rewrite fnorm_spec. unfold fz. cbn [fst snd fX fy fay fD fj faD]. | ||
| 1655 | fold aD D0 j0 y0 ay. | ||
| 1656 | replace (N.to_nat (fD F + N.of_nat a) + aD * u) with (D0 + aD * u + a) by (rewrite N2Nat.inj_add, Nat2N.id; lia). | ||
| 1657 | replace (N.to_nat (N.succ (fj F)) + aD * u) with (S (j0 + aD * u)) by (rewrite N2Nat.inj_succ; lia). | ||
| 1658 | apply Hstep. apply shiftX_app. exact Es. | ||
| 1659 | - destruct (N.eqb ay2 0 && N.eqb (faD F) 0) eqn:Ec; [|discriminate]. | ||
| 1660 | apply andb_prop in Ec. destruct Ec as [Ea Eb]. apply N.eqb_eq in Ea, Eb. | ||
| 1661 | destruct (shift (X2 ++ binN (fy F + e1 + e2))) as [Z3|] eqn:Ez; inversion H; subst. clear H. | ||
| 1662 | unfold CS, fz. cbn [fst snd fX fy fay fD fj faD]. | ||
| 1663 | fold aD D0 j0 y0 ay. | ||
| 1664 | assert (HaD : aD = O) by (unfold aD; rewrite Eb; reflexivity). | ||
| 1665 | replace (N.to_nat (fD F + N.of_nat a) + aD * u) with (D0 + aD * u + a) by (rewrite N2Nat.inj_add, Nat2N.id; lia). | ||
| 1666 | replace (N.to_nat (N.succ (fj F)) + aD * u) with (S (j0 + aD * u)) by (rewrite N2Nat.inj_succ; lia). | ||
| 1667 | cbn [N.to_nat] in *. rewrite Nat.mul_0_l, Nat.add_0_l, bin_0, app_nil_r. | ||
| 1668 | apply Hstep. rewrite Nat.mul_0_l, Nat.add_0_r. | ||
| 1669 | unfold bin. rewrite N2Nat.id. exact Ez. | ||
| 1670 | Qed. | ||
| 1672 | (* canonical states C(b) = S1 D0 D1^4 bin(b + 1), D = 32b + 16, j = 32b + 17 *) | ||
| 1673 | Definition Cst (b : nat) : st := ([uS1; uD0; uD1; uD1; uD1; uD1] ++ bin (S b), 32 * b + 16, 32 * b + 17). | ||
| 1675 | Definition unt_eq_dec (a b : unt) : {a = b} + {a <> b}. | ||
| 1676 | Proof. decide equality. Defined. | ||
| 1678 | Definition lsteqb (l1 l2 : list unt) : bool := if list_eq_dec unt_eq_dec l1 l2 then true else false. | ||
| 1680 | Definition canonb (F : fam) : bool := | ||
| 1681 | match fX F with | ||
| 1682 | | uS1 :: uD0 :: uD1 :: uD1 :: uD1 :: uD1 :: Xd => | ||
| 1683 | allb isdig Xd && N.leb 17 (fj F) && N.eqb ((fj F - 17) mod 32) 0 && N.eqb (fD F + 1) (fj F) && | ||
| 1684 | N.eqb (faD F mod 32) 0 && | ||
| 1685 | (if N.eqb (fay F) 0 && N.eqb (faD F) 0 then lsteqb (Xd ++ binN (fy F)) (binN ((fj F - 17) / 32 + 1)) | ||
| 1686 | else N.ltb 0 (fy F) && | ||
| 1687 | N.eqb (valN Xd + 2 ^ N.of_nat (length Xd) * fy F) ((fj F - 17) / 32 + 1) && | ||
| 1688 | N.eqb (2 ^ N.of_nat (length Xd) * fay F) (faD F / 32)) | ||
| 1689 | | _ => false | ||
| 1690 | end. | ||
| 1692 | Lemma canonb_sound F : canonb F = true -> exists b0 g, forall u, fz F u = Cst (b0 + g * u). | ||
| 1693 | Proof. | ||
| 1694 | unfold canonb. destruct (fX F) as [|[] [|[] [|[] [|[] [|[] [|[] Xd]]]]]] eqn:EX; try discriminate. | ||
| 1695 | intros H. | ||
| 1696 | apply andb_prop in H. destruct H as [H Hf]. | ||
| 1697 | apply andb_prop in H. destruct H as [H He]. | ||
| 1698 | apply andb_prop in H. destruct H as [H Hd]. | ||
| 1699 | apply andb_prop in H. destruct H as [H Hc]. | ||
| 1700 | apply andb_prop in H. destruct H as [Ha Hb]. | ||
| 1701 | apply N.leb_le in Hb. apply N.eqb_eq in Hc, Hd, He. | ||
| 1702 | exists (N.to_nat ((fj F - 17) / 32)), (N.to_nat (faD F / 32)). intros u. | ||
| 1703 | assert (E1 : N.to_nat (fj F - 17) mod 32 = O). | ||
| 1704 | { replace 32 with (N.to_nat 32) by reflexivity. rewrite <- N2Nat.inj_mod, Hc. reflexivity. } | ||
| 1705 | assert (E2 : N.to_nat (faD F) mod 32 = O). | ||
| 1706 | { replace 32 with (N.to_nat 32) by reflexivity. rewrite <- N2Nat.inj_mod, He. reflexivity. } | ||
| 1707 | assert (Hb' : 17 <= N.to_nat (fj F)) by lia. | ||
| 1708 | assert (Hd' : N.to_nat (fD F) + 1 = N.to_nat (fj F)) by (rewrite <- Hd; rewrite N2Nat.inj_add; reflexivity). | ||
| 1709 | rewrite N2Nat.inj_sub in E1. | ||
| 1710 | apply Nat.Div0.mod_divides in E1, E2. destruct E1 as [p Hp], E2 as [q Hq]. | ||
| 1711 | replace (N.to_nat 17) with 17 in Hp by reflexivity. | ||
| 1712 | assert (Ebj : N.to_nat ((fj F - 17) / 32) = p). | ||
| 1713 | { rewrite N2Nat.inj_div, N2Nat.inj_sub. replace (N.to_nat 17) with 17 by reflexivity. | ||
| 1714 | replace (N.to_nat 32) with 32 by reflexivity. rewrite Hp. rewrite Nat.mul_comm, Nat.div_mul; lia. } | ||
| 1715 | assert (Eg : N.to_nat (faD F / 32) = q). | ||
| 1716 | { rewrite N2Nat.inj_div. replace (N.to_nat 32) with 32 by reflexivity. rewrite Hq. | ||
| 1717 | rewrite Nat.mul_comm, Nat.div_mul; lia. } | ||
| 1718 | rewrite Ebj, Eg. | ||
| 1719 | unfold fz, Cst. rewrite EX. cbn [app]. | ||
| 1720 | f_equal; [f_equal|]. | ||
| 1721 | - do 6 f_equal. | ||
| 1722 | destruct (N.eqb (fay F) 0 && N.eqb (faD F) 0) eqn:Ec. | ||
| 1723 | + apply andb_prop in Ec. destruct Ec as [Ea Eb]. apply N.eqb_eq in Ea, Eb. | ||
| 1724 | unfold lsteqb in Hf. | ||
| 1725 | destruct (list_eq_dec unt_eq_dec (Xd ++ binN (fy F)) (binN ((fj F - 17) / 32 + 1))) as [Eq|]; [|discriminate]. | ||
| 1726 | rewrite Ea, Eb in *. cbn [N.to_nat] in *. rewrite !Nat.mul_0_l, !Nat.add_0_r. | ||
| 1727 | unfold bin. rewrite N2Nat.id, Eq. f_equal. | ||
| 1728 | apply N2Nat.inj. rewrite Nat2N.id, N2Nat.inj_add, Ebj. cbn. lia. | ||
| 1729 | + apply andb_prop in Hf. destruct Hf as [Hf H6]. | ||
| 1730 | apply andb_prop in Hf. destruct Hf as [H4 H5]. | ||
| 1731 | apply N.ltb_lt in H4. apply N.eqb_eq in H5, H6. | ||
| 1732 | rewrite (digits_val Xd Ha) at 1. | ||
| 1733 | rewrite digits_app_bin; [| apply val_lt; exact Ha | lia]. | ||
| 1734 | f_equal. | ||
| 1735 | apply (f_equal N.to_nat) in H5, H6. | ||
| 1736 | rewrite N2Nat.inj_add, N2Nat.inj_mul, N2Nat.inj_pow, valN_spec, Nat2N.id in H5. | ||
| 1737 | rewrite N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id in H6. | ||
| 1738 | rewrite N2Nat.inj_add, Ebj in H5. rewrite Eg in H6. | ||
| 1739 | change (N.to_nat 2) with 2%nat in H5, H6. | ||
| 1740 | change (N.to_nat 1) with 1%nat in H5. | ||
| 1741 | rewrite Nat.mul_add_distr_l, Nat.mul_assoc, H6. lia. | ||
| 1742 | - rewrite Hq. clear -Hd' Hp Hb'. nia. | ||
| 1743 | - rewrite Hq. clear -Hp Hb'. nia. | ||
| 1744 | Qed. | ||
| 1746 | Fixpoint frun (n R : nat) (F : fam) : bool := | ||
| 1747 | match n with | ||
| 1748 | | O => false | ||
| 1749 | | S n' => | ||
| 1750 | match fstep R F with | ||
| 1751 | | None => false | ||
| 1752 | | Some F' => canonb F' || frun n' R F' | ||
| 1753 | end | ||
| 1754 | end. | ||
| 1756 | Lemma frun_sound n R F : frun n R F = true -> forall u, exists b', CSplus (fz F u) (Cst b'). | ||
| 1757 | Proof. | ||
| 1758 | revert F; induction n as [|n IH]; intros F H u; [discriminate|]. | ||
| 1759 | cbn [frun] in H. destruct (fstep R F) as [F'|] eqn:E; [|discriminate]. | ||
| 1760 | pose proof (fstep_sound R F F' E u) as H1. | ||
| 1761 | destruct (canonb F') eqn:Ec. | ||
| 1762 | - destruct (canonb_sound F' Ec) as [b0 [g Hg]]. exists (b0 + g * u). rewrite <- Hg. constructor. exact H1. | ||
| 1763 | - cbn in H. destruct (IH F' H u) as [b' Hb']. exists b'. eapply CSpS; eauto. | ||
| 1764 | Qed. | ||
| 1766 | (* ===================================================================== *) | ||
| 1767 | (* 16. Small classes: C(b) with nu2(b + 2) <= 40 (proof.md 6.6). *) | ||
| 1768 | (* ===================================================================== *) | ||
| 1770 | Definition Zcl (b : N) : list unt := [uS1; uD0; uD1; uD1; uD1; uD1] ++ binN (b + 1). | ||
| 1772 | Definition sc_direct (k o0 : nat) : fam := | ||
| 1773 | let b := (N.of_nat o0 * 2 ^ N.of_nat k - 2)%N in | ||
| 1774 | mkF (Zcl b) 0 0 (32 * b + 16) (32 * b + 17) 0. | ||
| 1776 | Definition sc_fam (k o0 : nat) : fam := | ||
| 1777 | let j0 := (32 * ((N.of_nat o0 + 16) * 2 ^ N.of_nat k - 2) + 17)%N in | ||
| 1778 | mkF ([uS1; uD0] ++ repeat uD1 (k + 4) ++ uD0 :: digits 3 ((o0 - 1) / 2)) 1 1 (j0 - 1) j0 | ||
| 1779 | (2 ^ N.of_nat (k + 9)). | ||
| 1781 | Definition sc_ok (k o0 : nat) : bool := | ||
| 1782 | (if Nat.eqb k O && Nat.eqb o0 1%nat then true else frun 100 10000 (sc_direct k o0)) && | ||
| 1783 | frun 100 (k + 9) (sc_fam k o0). | ||
| 1785 | Fixpoint upto (n : nat) : list nat := match n with O => [] | S n' => upto n' ++ [n'] end. | ||
| 1787 | Lemma upto_In k n : k < n -> In k (upto n). | ||
| 1788 | Proof. | ||
| 1789 | induction n as [|n IH]; intros H; [lia|]. cbn [upto]. apply in_or_app. | ||
| 1790 | destruct (Nat.eq_dec k n) as [->|Hne]; [right; left; reflexivity|left; apply IH; lia]. | ||
| 1791 | Qed. | ||
| 1793 | Definition odds16 : list nat := [1%nat; 3; 5; 7; 9; 11; 13; 15]. | ||
| 1795 | Lemma sc_all : forallb (fun k => forallb (fun o0 => sc_ok k o0) odds16) (upto 41) = true. | ||
| 1796 | Proof. vm_compute. reflexivity. Qed. | ||
| 1798 | Lemma sc_ok_of k o0 : k <= 40 -> In o0 odds16 -> sc_ok k o0 = true. | ||
| 1799 | Proof. | ||
| 1800 | intros Hk Ho. pose proof sc_all as H. | ||
| 1801 | rewrite forallb_forall in H. specialize (H k (upto_In k 41 ltac:(lia))). | ||
| 1802 | rewrite forallb_forall in H. apply H. exact Ho. | ||
| 1803 | Qed. | ||
| 1805 | Lemma odd_decomp n : 0 < n -> exists k o, n = o * 2 ^ k /\ Nat.odd o = true. | ||
| 1806 | Proof. | ||
| 1807 | induction n as [n IH] using lt_wf_ind. intros Hn. | ||
| 1808 | destruct (Nat.odd n) eqn:Eo. | ||
| 1809 | - exists O, n. split; [cbn; lia|exact Eo]. | ||
| 1810 | - assert (Ee : Nat.even n = true) by (rewrite <- Nat.negb_odd, Eo; reflexivity). | ||
| 1811 | apply Nat.even_spec in Ee. destruct Ee as [m Hm]. | ||
| 1812 | destruct (IH m ltac:(lia) ltac:(lia)) as [k [o [E1 E2]]]. | ||
| 1813 | exists (S k), o. split; [rewrite Nat.pow_succ_r'; lia|exact E2]. | ||
| 1814 | Qed. | ||
| 1816 | Lemma Cst_zone k q b : b + 2 = (2 * q + 1) * 2 ^ k -> | ||
| 1817 | fst (fst (Cst b)) = [uS1; uD0; uD1; uD1; uD1; uD1] ++ repeat uD1 k ++ bin (2 * q). | ||
| 1818 | Proof. | ||
| 1819 | intros H. cbn [Cst fst]. f_equal. rewrite <- bin_ones. f_equal. | ||
| 1820 | rewrite Nat.pow_add_r, Nat.pow_1_r. pose proof (Nat.pow_nonzero 2 k). nia. | ||
| 1821 | Qed. | ||
| 1823 | Lemma odd_mod16 o : Nat.odd o = true -> In (o mod 16) odds16. | ||
| 1824 | Proof. | ||
| 1825 | intros H. assert (Ho : o mod 2 = 1%nat). | ||
| 1826 | { rewrite Nat.odd_spec in H. destruct H as [m Hm]. subst. rewrite Nat.add_comm, Nat.mul_comm, Nat.Div0.mod_add. reflexivity. } | ||
| 1827 | assert (E : o mod 16 mod 2 = 1%nat). | ||
| 1828 | { transitivity (o mod 2); [|exact Ho]. rewrite (Nat.div_mod_eq o 16) at 2. | ||
| 1829 | replace (16 * (o / 16) + o mod 16) with (o mod 16 + (8 * (o / 16)) * 2) by lia. | ||
| 1830 | rewrite Nat.Div0.mod_add. reflexivity. } | ||
| 1831 | assert (o mod 16 < 16) by (apply Nat.mod_upper_bound; lia). | ||
| 1832 | remember (o mod 16) as r. clear -E H0. | ||
| 1833 | do 16 (destruct r as [|r]; [cbn in E; try discriminate; cbn; tauto|]). lia. | ||
| 1834 | Qed. | ||
| 1836 | Lemma odds16_half r : In r odds16 -> r = 2 * ((r - 1) / 2) + 1. | ||
| 1837 | Proof. cbn. intros H. repeat (destruct H as [<-|H]; [reflexivity|]). destruct H. Qed. | ||
| 1839 | Theorem small_classes b k o : b + 2 = o * 2 ^ k -> Nat.odd o = true -> k <= 40 -> | ||
| 1840 | exists b', CSplus (Cst b) (Cst b'). | ||
| 1841 | Proof. | ||
| 1842 | intros Hb Ho Hk. | ||
| 1843 | set (o0 := o mod 16). | ||
| 1844 | assert (Hin : In o0 odds16) by (apply odd_mod16; exact Ho). | ||
| 1845 | pose proof (sc_ok_of k o0 Hk Hin) as Hok. unfold sc_ok in Hok. | ||
| 1846 | apply andb_prop in Hok. destruct Hok as [Hd Hf]. | ||
| 1847 | assert (Hpk := Nat.pow_nonzero 2 k ltac:(lia)). | ||
| 1848 | assert (Ho16 : o = o0 + 16 * (o / 16)) by (unfold o0; pose proof (Nat.div_mod o 16); lia). | ||
| 1849 | assert (Hq0 : o0 = 2 * ((o0 - 1) / 2) + 1) by (apply odds16_half; exact Hin). | ||
| 1850 | destruct (o / 16) as [|t] eqn:Et. | ||
| 1851 | - (* o = o0: direct run *) | ||
| 1852 | rewrite Nat.mul_0_r, Nat.add_0_r in Ho16. | ||
| 1853 | destruct (Nat.eqb k O && Nat.eqb o0 1%nat) eqn:E0. | ||
| 1854 | { apply andb_prop in E0. destruct E0 as [E1 E2]. apply Nat.eqb_eq in E1, E2. subst k. | ||
| 1855 | rewrite E2 in Ho16. subst o. cbn in Hb. lia. } | ||
| 1856 | destruct (frun_sound _ _ _ Hd 0) as [b' Hb']. | ||
| 1857 | exists b'. replace (Cst b) with (fz (sc_direct k o0) 0); [exact Hb'|]. | ||
| 1858 | unfold fz, sc_direct, Cst, Zcl. cbn [fX fy fay fD fj faD]. | ||
| 1859 | assert (Eb : (N.of_nat o0 * 2 ^ N.of_nat k - 2 = N.of_nat b)%N). | ||
| 1860 | { apply N2Nat.inj. rewrite Nat2N.id, N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, !Nat2N.id. | ||
| 1861 | change (N.to_nat 2) with 2%nat. rewrite <- Ho16. lia. } | ||
| 1862 | rewrite Eb. cbn [N.to_nat]. rewrite !Nat.mul_0_r, !Nat.add_0_r, bin_0, app_nil_r. | ||
| 1863 | f_equal; [f_equal|]. | ||
| 1864 | + f_equal. unfold bin. f_equal. lia. | ||
| 1865 | + rewrite N2Nat.inj_add, N2Nat.inj_mul, Nat2N.id. reflexivity. | ||
| 1866 | + rewrite N2Nat.inj_add, N2Nat.inj_mul, Nat2N.id. reflexivity. | ||
| 1867 | - (* o = o0 + 16 (1 + t): the family at u = t *) | ||
| 1868 | destruct (frun_sound _ _ _ Hf t) as [b' Hb']. | ||
| 1869 | exists b'. replace (Cst b) with (fz (sc_fam k o0) t); [exact Hb'|]. | ||
| 1870 | set (q0 := (o0 - 1) / 2) in *. | ||
| 1871 | set (q := q0 + 8 * (1 + t)). | ||
| 1872 | assert (Hoq : o = 2 * q + 1) by (unfold q; lia). | ||
| 1873 | assert (Hz := Cst_zone k q b ltac:(rewrite <- Hoq; exact Hb)). | ||
| 1874 | destruct (Cst b) as [[zc dc] jc] eqn:EC. cbn [fst] in Hz. subst zc. | ||
| 1875 | unfold Cst in EC. inversion EC; subst dc jc. clear EC. | ||
| 1876 | unfold fz, sc_fam. cbn [fX fy fay fD fj faD]. | ||
| 1877 | f_equal; [f_equal|]. | ||
| 1878 | + rewrite Nat.add_comm, repeat_app. cbn [repeat app]. rewrite <- !app_assoc. cbn [app]. | ||
| 1879 | do 6 f_equal. f_equal. | ||
| 1880 | rewrite (bin_pos (2 * q)) by (unfold q; lia). | ||
| 1881 | rewrite dig_even. f_equal. | ||
| 1882 | replace (2 * q / 2) with q by (rewrite Nat.mul_comm, Nat.div_mul; lia). | ||
| 1883 | change (N.to_nat 1) with 1%nat. | ||
| 1884 | rewrite digits_app_bin. | ||
| 1885 | * f_equal. unfold q, q0. cbn. lia. | ||
| 1886 | * assert (o0 < 16) by (unfold o0; apply Nat.mod_upper_bound; lia). | ||
| 1887 | change (2 ^ 3) with 8%nat. apply Nat.Div0.div_lt_upper_bound. lia. | ||
| 1888 | * lia. | ||
| 1889 | + rewrite N2Nat.inj_sub, N2Nat.inj_add, N2Nat.inj_mul, N2Nat.inj_sub, N2Nat.inj_mul, | ||
| 1890 | !N2Nat.inj_pow, N2Nat.inj_add, !Nat2N.id. | ||
| 1891 | change (N.to_nat 2) with 2%nat. change (N.to_nat 32) with 32%nat. | ||
| 1892 | change (N.to_nat 16) with 16%nat. change (N.to_nat 17) with 17%nat. change (N.to_nat 1) with 1%nat. | ||
| 1893 | rewrite Nat.pow_add_r. change (2 ^ 9) with 512%nat. | ||
| 1894 | assert (2 <= (o0 + 16) * 2 ^ k) by nia. | ||
| 1895 | rewrite Ho16 in Hb. nia. | ||
| 1896 | + rewrite N2Nat.inj_add, N2Nat.inj_mul, N2Nat.inj_sub, N2Nat.inj_mul, | ||
| 1897 | !N2Nat.inj_pow, N2Nat.inj_add, !Nat2N.id. | ||
| 1898 | change (N.to_nat 2) with 2%nat. change (N.to_nat 32) with 32%nat. | ||
| 1899 | change (N.to_nat 16) with 16%nat. change (N.to_nat 17) with 17%nat. | ||
| 1900 | rewrite Nat.pow_add_r. change (2 ^ 9) with 512%nat. | ||
| 1901 | assert (2 <= (o0 + 16) * 2 ^ k) by nia. | ||
| 1902 | rewrite Ho16 in Hb. nia. | ||
| 1903 | Qed. | ||
| 1905 | (* ===================================================================== *) | ||
| 1906 | (* 17. Value forms (proof.md 6.2): digits of V with heads at positions *) | ||
| 1907 | (* 0..3 and the marker P at position L. *) | ||
| 1908 | (* ===================================================================== *) | ||
| 1910 | Fixpoint vfl (hs : list (list unt)) (L V : nat) : list unt := | ||
| 1911 | match L with | ||
| 1912 | | O => uP :: bin V | ||
| 1913 | | S L' => hd [] hs ++ dig V :: vfl (tl hs) L' (V / 2) | ||
| 1914 | end. | ||
| 1916 | Fixpoint vlow (hs : list (list unt)) (L R V : nat) : list unt := | ||
| 1917 | match L with | ||
| 1918 | | O => uP :: digits R V | ||
| 1919 | | S L' => | ||
| 1920 | match R with | ||
| 1921 | | O => [] | ||
| 1922 | | S R' => hd [] hs ++ dig V :: vlow (tl hs) L' R' (V / 2) | ||
| 1923 | end | ||
| 1924 | end. | ||
| 1926 | Lemma digits_mod R V s : digits R (V + 2 ^ R * s) = digits R V. | ||
| 1927 | Proof. | ||
| 1928 | revert V; induction R as [|R IH]; intros V; [reflexivity|]. | ||
| 1929 | cbn [digits]. rewrite Nat.pow_succ_r'. | ||
| 1930 | replace (V + 2 * 2 ^ R * s) with (V + 2 * (2 ^ R * s)) by lia. | ||
| 1931 | rewrite dig_add_even, div2_add_even, IH. reflexivity. | ||
| 1932 | Qed. | ||
| 1934 | Lemma digits_bin_split R V : 2 ^ R <= V -> bin V = digits R V ++ bin (V / 2 ^ R). | ||
| 1935 | Proof. | ||
| 1936 | intros H. pose proof (Nat.pow_nonzero 2 R ltac:(lia)) as Hp. | ||
| 1937 | pose proof (Nat.div_mod_eq V (2 ^ R)) as Ed. | ||
| 1938 | assert (E : digits R V = digits R (V mod 2 ^ R)). | ||
| 1939 | { rewrite <- (digits_mod R (V mod 2 ^ R) (V / 2 ^ R)). f_equal. lia. } | ||
| 1940 | rewrite E, digits_app_bin. | ||
| 1941 | - f_equal. lia. | ||
| 1942 | - apply Nat.mod_upper_bound. lia. | ||
| 1943 | - apply Nat.div_str_pos. lia. | ||
| 1944 | Qed. | ||
| 1946 | Lemma vfl_split hs L R V : L < R -> 2 ^ R <= V -> vfl hs L V = vlow hs L R V ++ bin (V / 2 ^ R). | ||
| 1947 | Proof. | ||
| 1948 | revert hs R V; induction L as [|L IH]; intros hs R V HL HV. | ||
| 1949 | - cbn [vfl vlow app]. f_equal. apply digits_bin_split. exact HV. | ||
| 1950 | - destruct R as [|R]; [lia|]. cbn [vfl vlow]. rewrite <- app_assoc. cbn [app]. f_equal. f_equal. | ||
| 1951 | rewrite (IH (tl hs) R (V / 2)) by (try lia; rewrite Nat.pow_succ_r' in HV; apply Nat.div_le_lower_bound; lia). | ||
| 1952 | f_equal. f_equal. rewrite Nat.Div0.div_div. rewrite Nat.pow_succ_r'. reflexivity. | ||
| 1953 | Qed. | ||
| 1955 | Lemma vlow_mod hs L R V s : vlow hs L R (V + 2 ^ R * s) = vlow hs L R V. | ||
| 1956 | Proof. | ||
| 1957 | revert hs R V; induction L as [|L IH]; intros hs R V. | ||
| 1958 | - cbn [vlow]. rewrite digits_mod. reflexivity. | ||
| 1959 | - destruct R as [|R]; [reflexivity|]. cbn [vlow]. rewrite Nat.pow_succ_r'. | ||
| 1960 | replace (V + 2 * 2 ^ R * s) with (V + 2 * (2 ^ R * s)) by lia. | ||
| 1961 | rewrite dig_add_even, div2_add_even, IH. reflexivity. | ||
| 1962 | Qed. | ||
| 1964 | (* rows: heads at positions 0..3, lambda, mu, the w slope alpha, w = alpha off + wp - wn, D = j - d *) | ||
| 1965 | Record vrow := mkV { vh : list (list unt); vlam : nat; vmu : nat; val_ : nat; vwp : nat; vwn : nat; vd : nat }. | ||
| 1967 | Definition phrows : list vrow := | ||
| 1968 | [ mkV [[uS1]] 24 1 1 0 20 2; | ||
| 1969 | mkV [[uS1]] 24 1 1 0 20 2; | ||
| 1970 | mkV [[]; [uS1]] 24 1 1 0 20 2; | ||
| 1971 | mkV [[]; [uSP]] 25 2 2 0 42 3; | ||
| 1972 | mkV [[uS1; uP; uP]] 24 1 1 0 24 4; | ||
| 1973 | mkV [[]; []; [uS1]] 24 1 1 0 21 2; | ||
| 1974 | mkV [[]; [uS1; uP]] 24 1 1 0 24 3; | ||
| 1975 | mkV [[uS1; uP; uP]] 24 1 1 0 24 4 ]. | ||
| 1977 | Definition phrow (phi : nat) : vrow := nth phi phrows (mkV [] 24 1 1 0 24 4). | ||
| 1979 | Definition vfz (r : vrow) (k Om off : nat) : st := | ||
| 1980 | let L := k + vlam r - off in | ||
| 1981 | let V := vmu r * Om + val_ r * off + vwp r - (vwn r + 3 * 2 ^ (L - 1)) in | ||
| 1982 | let j := Om + off - 64 in | ||
| 1983 | (vfl (vh r) L V, j - vd r, j). | ||
| 1985 | Definition off_end (k : nat) : nat := if Nat.eqb ((k + 20) mod 8) 3 then k + 21 else k + 20. | ||
| 1987 | Definition VFe (k Om : nat) : st := vfz (phrow (off_end k mod 8)) k Om (off_end k). | ||
| 1989 | (* the same in N, for the family bases *) | ||
| 1990 | Fixpoint digitsN (r : nat) (v : N) : list unt := | ||
| 1991 | match r with O => [] | S r' => digN v :: digitsN r' (N.div2 v) end. | ||
| 1993 | Lemma digitsN_spec r v : digitsN r v = digits r (N.to_nat v). | ||
| 1994 | Proof. | ||
| 1995 | revert v; induction r as [|r IH]; intros v; [reflexivity|]. cbn [digitsN digits]. | ||
| 1996 | rewrite IH, digN_dig, N2Nat.inj_div2, Nat.div2_div. reflexivity. | ||
| 1997 | Qed. | ||
| 1999 | Fixpoint vlowN (hs : list (list unt)) (L R : nat) (V : N) : list unt := | ||
| 2000 | match L with | ||
| 2001 | | O => uP :: digitsN R V | ||
| 2002 | | S L' => | ||
| 2003 | match R with | ||
| 2004 | | O => [] | ||
| 2005 | | S R' => hd [] hs ++ digN V :: vlowN (tl hs) L' R' (N.div2 V) | ||
| 2006 | end | ||
| 2007 | end. | ||
| 2009 | Lemma vlowN_spec hs L R V : vlowN hs L R V = vlow hs L R (N.to_nat V). | ||
| 2010 | Proof. | ||
| 2011 | revert hs R V; induction L as [|L IH]; intros hs R V; cbn [vlowN vlow]. | ||
| 2012 | - rewrite digitsN_spec. reflexivity. | ||
| 2013 | - destruct R; [reflexivity|]. rewrite IH, digN_dig, N2Nat.inj_div2, Nat.div2_div. reflexivity. | ||
| 2014 | Qed. | ||
| 2016 | (* the family of VF states at the end offset: base (k0, Om0), cut R; all in N *) | ||
| 2017 | Definition off_endN (k : N) : N := if N.eqb ((k + 20) mod 8) 3 then (k + 21)%N else (k + 20)%N. | ||
| 2019 | Definition egr (k0 : N) : vrow := phrow (N.to_nat (off_endN k0 mod 8)). | ||
| 2021 | Definition egL (k0 : N) : nat := N.to_nat (k0 + N.of_nat (vlam (egr k0)) - off_endN k0). | ||
| 2023 | Definition egV (k0 : N) (Om0 : N) : N := | ||
| 2024 | (N.of_nat (vmu (egr k0)) * Om0 + N.of_nat (val_ (egr k0)) * off_endN k0 + N.of_nat (vwp (egr k0)) - | ||
| 2025 | N.of_nat (vwn (egr k0) + 3 * 2 ^ (egL k0 - 1)))%N. | ||
| 2027 | Definition egF (k0 : N) (Om0 : N) (R : nat) : fam := | ||
| 2028 | let j0 := (Om0 + off_endN k0 - 64)%N in | ||
| 2029 | mkF (vlowN (vh (egr k0)) (egL k0) R (egV k0 Om0)) (egV k0 Om0 / 2 ^ N.of_nat R) 1 | ||
| 2030 | (j0 - N.of_nat (vd (egr k0))) j0 (2 ^ N.of_nat R). | ||
| 2032 | Definition egok (k0 : N) (Om0 : N) (R : nat) : bool := | ||
| 2033 | Nat.ltb (egL k0) R && N.leb (2 ^ N.of_nat R) (egV k0 Om0) && N.leb 64 Om0 && | ||
| 2034 | Nat.eqb (vmu (egr k0)) 1 && Nat.eqb (val_ (egr k0)) 1 && Nat.leb (vd (egr k0)) 20 && | ||
| 2035 | frun 120 R (egF k0 Om0 R). | ||
| 2037 | Definition egbase (kap : nat) : N := N.of_nat (if Nat.ltb kap 41 then kap + 4096 else kap). | ||
| 2039 | Definition eg_ok (kap : nat) : bool := | ||
| 2040 | Nat.eqb ((kap + 9) mod 2048) O || egok (egbase kap) (2 ^ 46) 12. | ||
| 2042 | Lemma eg_all : forallb eg_ok (upto 4096) = true. | ||
| 2043 | Proof. vm_compute. reflexivity. Qed. | ||
| 2045 | Definition ns_ok (v : nat) (s0 : N) : bool := | ||
| 2046 | egok (s0 * 2 ^ N.of_nat v - 9) (2 ^ N.of_nat (v + 10)) (v + 2). | ||
| 2048 | Lemma ns_all : forallb (fun v => ns_ok (v + 11) 1 && ns_ok (v + 11) 3) (upto 40) = true. | ||
| 2049 | Proof. vm_compute. reflexivity. Qed. | ||
| 2051 | Lemma off_endN_spec k : N.to_nat (off_endN k) = off_end (N.to_nat k). | ||
| 2052 | Proof. | ||
| 2053 | unfold off_endN, off_end. | ||
| 2054 | replace (N.eqb ((k + 20) mod 8) 3) with (Nat.eqb ((N.to_nat k + 20) mod 8) 3). | ||
| 2055 | - destruct (Nat.eqb _ _); lia. | ||
| 2056 | - rewrite <- (N2Nat.id ((k + 20) mod 8)). rewrite N2Nat.inj_mod, N2Nat.inj_add. | ||
| 2057 | change (N.to_nat 20) with 20%nat. change (N.to_nat 8) with 8%nat. | ||
| 2058 | destruct (Nat.eqb_spec ((N.to_nat k + 20) mod 8) 3) as [E|E]; symmetry. | ||
| 2059 | + apply N.eqb_eq. rewrite E. reflexivity. | ||
| 2060 | + apply N.eqb_neq. intros C. apply E. apply (f_equal N.to_nat) in C. rewrite Nat2N.id in C. exact C. | ||
| 2061 | Qed. | ||
| 2063 | Lemma mod8_of k k0 R : 3 <= R -> k0 <= k -> (k - k0) mod 2 ^ R = O -> k mod 8 = k0 mod 8. | ||
| 2064 | Proof. | ||
| 2065 | intros HR Hk H. apply Nat.Div0.mod_divides in H. destruct H as [c Hc]. | ||
| 2066 | replace k with (k0 + (2 ^ (R - 3) * c) * 8). | ||
| 2067 | - apply Nat.Div0.mod_add. | ||
| 2068 | - replace R with (3 + (R - 3)) in Hc by lia. rewrite Nat.pow_add_r in Hc. cbn in Hc. lia. | ||
| 2069 | Qed. | ||
| 2071 | Lemma off_end_shift k k0 : k mod 8 = k0 mod 8 -> off_end k = k + (off_end k0 - k0) /\ k0 + 20 <= off_end k0 /\ | ||
| 2072 | off_end k mod 8 = off_end k0 mod 8. | ||
| 2073 | Proof. | ||
| 2074 | intros H. unfold off_end. | ||
| 2075 | assert (E : (k + 20) mod 8 = (k0 + 20) mod 8). | ||
| 2076 | { rewrite (Nat.Div0.add_mod k), (Nat.Div0.add_mod k0), H. reflexivity. } | ||
| 2077 | rewrite E. destruct (Nat.eqb ((k0 + 20) mod 8) 3); (split; [lia|split; [lia|]]). | ||
| 2078 | - replace (k + 21) with (k + 21) by reflexivity. rewrite (Nat.Div0.add_mod k), (Nat.Div0.add_mod k0), H. reflexivity. | ||
| 2079 | - rewrite (Nat.Div0.add_mod k), (Nat.Div0.add_mod k0), H. reflexivity. | ||
| 2080 | Qed. | ||
| 2082 | Lemma eg_family k0 Om0 R k Om : egok k0 Om0 R = true -> 3 <= R -> N.to_nat k0 <= k -> | ||
| 2083 | (k - N.to_nat k0) mod 2 ^ R = O -> N.to_nat Om0 <= Om -> (Om - N.to_nat Om0) mod 2 ^ R = O -> | ||
| 2084 | exists b', CSplus (VFe k Om) (Cst b'). | ||
| 2085 | Proof. | ||
| 2086 | intros Hok HR Hk HkR HO HOR. | ||
| 2087 | unfold egok in Hok. | ||
| 2088 | apply andb_prop in Hok. destruct Hok as [Hok Hrun]. | ||
| 2089 | apply andb_prop in Hok. destruct Hok as [Hok Hd]. | ||
| 2090 | apply andb_prop in Hok. destruct Hok as [Hok Hal]. | ||
| 2091 | apply andb_prop in Hok. destruct Hok as [Hok Hmu]. | ||
| 2092 | apply andb_prop in Hok. destruct Hok as [Hok H64]. | ||
| 2093 | apply andb_prop in Hok. destruct Hok as [HL HV]. | ||
| 2094 | apply Nat.ltb_lt in HL. apply N.leb_le in HV, H64. apply Nat.eqb_eq in Hmu, Hal. apply Nat.leb_le in Hd. | ||
| 2095 | assert (Hpr := Nat.pow_nonzero 2 R ltac:(lia)). | ||
| 2096 | apply Nat.Div0.mod_divides in HkR, HOR. destruct HkR as [ck Hck], HOR as [cO HcO]. | ||
| 2097 | set (u := cO + ck). | ||
| 2098 | destruct (frun_sound _ _ _ Hrun u) as [b' Hb']. exists b'. | ||
| 2099 | replace (VFe k Om) with (fz (egF k0 Om0 R) u); [exact Hb'|]. | ||
| 2100 | set (n0 := N.to_nat k0) in *. | ||
| 2101 | assert (H8 : k mod 8 = n0 mod 8). | ||
| 2102 | { apply (mod8_of k n0 R); auto. rewrite Hck, Nat.mul_comm, Nat.Div0.mod_mul. reflexivity. } | ||
| 2103 | destruct (off_end_shift k n0 H8) as [Eoff [Hoff Eom]]. | ||
| 2104 | set (off0 := off_end n0) in *. | ||
| 2105 | assert (Eo0 : N.to_nat (off_endN k0) = off0) by (unfold off0, n0; apply off_endN_spec). | ||
| 2106 | assert (Er : egr k0 = phrow (off_end k mod 8)). | ||
| 2107 | { unfold egr. rewrite Eom. f_equal. rewrite N2Nat.inj_mod, Eo0. reflexivity. } | ||
| 2108 | set (r := egr k0) in *. | ||
| 2109 | assert (EL : egL k0 = k + vlam r - off_end k). | ||
| 2110 | { unfold egL. fold r. rewrite N2Nat.inj_sub, N2Nat.inj_add, Nat2N.id, Eo0. fold n0. lia. } | ||
| 2111 | set (L := egL k0) in *. | ||
| 2112 | set (Om0' := N.to_nat Om0) in *. | ||
| 2113 | assert (EV0 : N.to_nat (egV k0 Om0) = Om0' + off0 + vwp r - (vwn r + 3 * 2 ^ (L - 1))). | ||
| 2114 | { unfold egV. fold r L. rewrite N2Nat.inj_sub, !N2Nat.inj_add, !N2Nat.inj_mul, !Nat2N.id, Eo0, Hmu, Hal. | ||
| 2115 | fold Om0'. lia. } | ||
| 2116 | set (V0 := N.to_nat (egV k0 Om0)) in *. | ||
| 2117 | assert (HV' : 2 ^ R <= V0). | ||
| 2118 | { unfold V0. replace (2 ^ R) with (N.to_nat (2 ^ N.of_nat R)) by (rewrite N2Nat.inj_pow, Nat2N.id; reflexivity). lia. } | ||
| 2119 | assert (EV : vmu r * Om + val_ r * off_end k + vwp r - (vwn r + 3 * 2 ^ (k + vlam r - off_end k - 1)) | ||
| 2120 | = V0 + 2 ^ R * u). | ||
| 2121 | { rewrite <- EL. fold L. rewrite Hmu, Hal. unfold u. rewrite Eoff. lia. } | ||
| 2122 | unfold VFe, vfz. rewrite <- Er. fold r. rewrite EV, <- EL. fold L. | ||
| 2123 | unfold fz, egF. cbn [fX fy fay fD fj faD]. fold r L. rewrite vlowN_spec. fold V0. | ||
| 2124 | assert (Ep : N.to_nat (2 ^ N.of_nat R) = 2 ^ R) by (rewrite N2Nat.inj_pow, Nat2N.id; reflexivity). | ||
| 2125 | f_equal; [f_equal|]. | ||
| 2126 | - rewrite (vfl_split (vh r) L R (V0 + 2 ^ R * u)) by lia. | ||
| 2127 | rewrite vlow_mod, div_mod_shift. f_equal. f_equal. | ||
| 2128 | rewrite N2Nat.inj_div, Ep. change (N.to_nat 1) with 1%nat. fold V0. lia. | ||
| 2129 | - rewrite Ep, N2Nat.inj_sub, N2Nat.inj_sub, N2Nat.inj_add, Eo0, Nat2N.id. | ||
| 2130 | change (N.to_nat 64) with 64%nat. fold Om0'. unfold u. rewrite Eoff. | ||
| 2131 | assert (64 <= Om0') by (unfold Om0'; lia). lia. | ||
| 2132 | - rewrite Ep, N2Nat.inj_sub, N2Nat.inj_add, Eo0. | ||
| 2133 | change (N.to_nat 64) with 64%nat. fold Om0'. unfold u. rewrite Eoff. | ||
| 2134 | assert (64 <= Om0') by (unfold Om0'; lia). lia. | ||
| 2135 | Qed. | ||
| 2137 | Lemma pow_le_mono2 a b : a <= b -> 2 ^ a <= 2 ^ b. | ||
| 2138 | Proof. intros H. apply Nat.pow_le_mono_r; lia. Qed. | ||
| 2140 | Lemma pow_mod_sub a b c U : c <= a -> c <= b -> 2 ^ b <= U * 2 ^ a -> (U * 2 ^ a - 2 ^ b) mod 2 ^ c = O. | ||
| 2141 | Proof. | ||
| 2142 | intros Ha Hb H. | ||
| 2143 | replace a with (c + (a - c)) by lia. replace b with (c + (b - c)) by lia. | ||
| 2144 | rewrite !Nat.pow_add_r. | ||
| 2145 | replace (U * (2 ^ c * 2 ^ (a - c)) - 2 ^ c * 2 ^ (b - c)) with ((U * 2 ^ (a - c) - 2 ^ (b - c)) * 2 ^ c). | ||
| 2146 | - apply Nat.Div0.mod_mul. | ||
| 2147 | - rewrite Nat.mul_sub_distr_r. f_equal; lia. | ||
| 2148 | Qed. | ||
| 2150 | (* the endgame of proof.md 6.4 with the cut R = 12 (proof.md 10): nu2(k + 9) <= 10 *) | ||
| 2151 | Theorem endgame k U : 41 <= k -> (k + 9) mod 2048 <> O -> 1 <= U -> | ||
| 2152 | exists b', CSplus (VFe k (U * 2 ^ (k + 5))) (Cst b'). | ||
| 2153 | Proof. | ||
| 2154 | intros Hk Hv HU. | ||
| 2155 | set (kap := k mod 4096). | ||
| 2156 | assert (Hkap : kap < 4096) by (apply Nat.mod_upper_bound; lia). | ||
| 2157 | pose proof eg_all as H. rewrite forallb_forall in H. specialize (H kap (upto_In _ _ Hkap)). | ||
| 2158 | unfold eg_ok in H. | ||
| 2159 | assert (Ev : (kap + 9) mod 2048 = (k + 9) mod 2048). | ||
| 2160 | { unfold kap. rewrite (Nat.div_mod_eq k 4096) at 2. | ||
| 2161 | replace (4096 * (k / 4096) + k mod 4096 + 9) with ((k mod 4096 + 9) + (2 * (k / 4096)) * 2048) by lia. | ||
| 2162 | rewrite Nat.Div0.mod_add. reflexivity. } | ||
| 2163 | rewrite Ev in H. destruct (Nat.eqb_spec ((k + 9) mod 2048) O) as [E|_]; [contradiction|]. cbn [orb] in H. | ||
| 2164 | assert (Ek : k = 4096 * (k / 4096) + kap) by (apply Nat.div_mod_eq). | ||
| 2165 | assert (E0 : N.to_nat (egbase kap) = if Nat.ltb kap 41 then kap + 4096 else kap). | ||
| 2166 | { unfold egbase. apply Nat2N.id. } | ||
| 2167 | assert (Hpk : 2 ^ 46 <= 2 ^ (k + 5)) by (apply pow_le_mono2; lia). | ||
| 2168 | eapply (eg_family (egbase kap) (2 ^ 46) 12); [exact H|lia| | | |]. | ||
| 2169 | - rewrite E0. destruct (Nat.ltb_spec kap 41); [|lia]. | ||
| 2170 | assert (1 <= k / 4096) by (destruct (k / 4096); lia). lia. | ||
| 2171 | - rewrite E0. replace (2 ^ 12) with 4096 by reflexivity. | ||
| 2172 | destruct (Nat.ltb_spec kap 41). | ||
| 2173 | + assert (1 <= k / 4096) by (destruct (k / 4096); lia). | ||
| 2174 | replace (k - (kap + 4096)) with ((k / 4096 - 1) * 4096) by lia. apply Nat.Div0.mod_mul. | ||
| 2175 | + replace (k - kap) with ((k / 4096) * 4096) by lia. apply Nat.Div0.mod_mul. | ||
| 2176 | - rewrite N2Nat.inj_pow. change (N.to_nat 2) with 2%nat. change (N.to_nat 46) with 46%nat. nia. | ||
| 2177 | - rewrite N2Nat.inj_pow. change (N.to_nat 2) with 2%nat. change (N.to_nat 46) with 46%nat. | ||
| 2178 | apply pow_mod_sub; [lia|lia|nia]. | ||
| 2179 | Qed. | ||
| 2181 | (* the nested range of proof.md 6.5 for 11 <= v <= 50 (proof.md 10) *) | ||
| 2182 | Theorem nested k U s v : k + 9 = s * 2 ^ v -> Nat.odd s = true -> 11 <= v <= 50 -> 1 <= U -> | ||
| 2183 | exists b', CSplus (VFe k (U * 2 ^ (k + 5))) (Cst b'). | ||
| 2184 | Proof. | ||
| 2185 | intros Hks Hs Hv HU. | ||
| 2186 | pose proof ns_all as H. rewrite forallb_forall in H. | ||
| 2187 | specialize (H (v - 11) (upto_In (v - 11) 40 ltac:(lia))). replace (v - 11 + 11) with v in H by lia. | ||
| 2188 | apply andb_prop in H. destruct H as [H1 H3]. | ||
| 2189 | assert (Hpv := Nat.pow_nonzero 2 v ltac:(lia)). | ||
| 2190 | assert (Hv2 : 2 ^ 11 <= 2 ^ v) by (apply pow_le_mono2; lia). | ||
| 2191 | change (2 ^ 11) with 2048%nat in Hv2. | ||
| 2192 | assert (Hsm : s mod 4 = 1%nat \/ s mod 4 = 3). | ||
| 2193 | { rewrite Nat.odd_spec in Hs. destruct Hs as [m Hm]. subst s. | ||
| 2194 | pose proof (Nat.mod_upper_bound (2 * m + 1) 4 ltac:(lia)). | ||
| 2195 | assert (E : (2 * m + 1) mod 4 = (2 * (m mod 2) + 1) mod 4). | ||
| 2196 | { rewrite (Nat.div_mod_eq m 2) at 1. | ||
| 2197 | replace (2 * (2 * (m / 2) + m mod 2) + 1) with ((2 * (m mod 2) + 1) + (m / 2) * 4) by lia. | ||
| 2198 | apply Nat.Div0.mod_add. } | ||
| 2199 | pose proof (Nat.mod_upper_bound m 2 ltac:(lia)). | ||
| 2200 | destruct (m mod 2) as [|[|]] eqn:Em; [left|right|lia]; rewrite E; reflexivity. } | ||
| 2201 | assert (Hdec : s = 4 * (s / 4) + s mod 4) by apply Nat.div_mod_eq. | ||
| 2202 | assert (Hk5 : v + 10 <= k + 5). | ||
| 2203 | { assert (v + 6 <= 2 ^ v). | ||
| 2204 | { clear -Hv. assert (forall n, 4 <= n -> n + 6 <= 2 ^ n). | ||
| 2205 | { induction n; intros Hn; [lia|]. destruct (Nat.eq_dec n 3) as [->|]; [cbn; lia|]. | ||
| 2206 | rewrite Nat.pow_succ_r'. specialize (IHn ltac:(lia)). lia. } | ||
| 2207 | apply H; lia. } | ||
| 2208 | assert (1 <= s) by (destruct s; [discriminate|lia]). nia. } | ||
| 2209 | assert (Hpk : 2 ^ (v + 10) <= 2 ^ (k + 5)) by (apply pow_le_mono2; lia). | ||
| 2210 | destruct Hsm as [Hsm|Hsm]; rewrite Hsm in Hdec. | ||
| 2211 | - eapply (eg_family _ _ (v + 2) k _ H1); [lia| | | |]. | ||
| 2212 | + rewrite N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id. change (N.to_nat 1) with 1%nat. | ||
| 2213 | change (N.to_nat 2) with 2%nat. change (N.to_nat 9) with 9%nat. nia. | ||
| 2214 | + rewrite N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id. change (N.to_nat 1) with 1%nat. | ||
| 2215 | change (N.to_nat 2) with 2%nat. change (N.to_nat 9) with 9%nat. | ||
| 2216 | replace (k - (1 * 2 ^ v - 9)) with ((s / 4) * 2 ^ (v + 2)). | ||
| 2217 | * apply Nat.Div0.mod_mul. | ||
| 2218 | * rewrite Nat.pow_add_r. change (2 ^ 2) with 4%nat. nia. | ||
| 2219 | + rewrite N2Nat.inj_pow, Nat2N.id. change (N.to_nat 2) with 2%nat. nia. | ||
| 2220 | + rewrite N2Nat.inj_pow, Nat2N.id. change (N.to_nat 2) with 2%nat. apply pow_mod_sub; [lia|lia|nia]. | ||
| 2221 | - eapply (eg_family _ _ (v + 2) k _ H3); [lia| | | |]. | ||
| 2222 | + rewrite N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id. | ||
| 2223 | change (N.to_nat 3) with 3%nat. change (N.to_nat 2) with 2%nat. change (N.to_nat 9) with 9%nat. nia. | ||
| 2224 | + rewrite N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id. | ||
| 2225 | change (N.to_nat 3) with 3%nat. change (N.to_nat 2) with 2%nat. change (N.to_nat 9) with 9%nat. | ||
| 2226 | replace (k - (3 * 2 ^ v - 9)) with ((s / 4) * 2 ^ (v + 2)). | ||
| 2227 | * apply Nat.Div0.mod_mul. | ||
| 2228 | * rewrite Nat.pow_add_r. change (2 ^ 2) with 4%nat. nia. | ||
| 2229 | + rewrite N2Nat.inj_pow, Nat2N.id. change (N.to_nat 2) with 2%nat. nia. | ||
| 2230 | + rewrite N2Nat.inj_pow, Nat2N.id. change (N.to_nat 2) with 2%nat. apply pow_mod_sub; [lia|lia|nia]. | ||
| 2231 | Qed. | ||
| 2233 | Lemma odd_not_mod2048 s v : Nat.odd s = true -> v <= 10 -> (s * 2 ^ v) mod 2048 <> O. | ||
| 2234 | Proof. | ||
| 2235 | intros Hs Hv E. apply Nat.Div0.mod_divides in E. destruct E as [t Ht]. | ||
| 2236 | assert (E2 : 2048 = 2 ^ v * 2 ^ (11 - v)). | ||
| 2237 | { rewrite <- Nat.pow_add_r. replace (v + (11 - v)) with 11 by lia. reflexivity. } | ||
| 2238 | rewrite E2 in Ht. | ||
| 2239 | assert (Hp := Nat.pow_nonzero 2 v ltac:(lia)). | ||
| 2240 | assert (Es : s = 2 ^ (11 - v) * t). | ||
| 2241 | { apply (Nat.mul_cancel_r _ _ (2 ^ v)); [lia|]. rewrite Ht. lia. } | ||
| 2242 | replace (11 - v) with (S (10 - v)) in Es by lia. rewrite Nat.pow_succ_r' in Es. | ||
| 2243 | rewrite Es in Hs. rewrite <- Nat.mul_assoc in Hs. rewrite Nat.odd_mul in Hs. discriminate. | ||
| 2244 | Qed. | ||
| 2246 | (* E(K) of proof.md 6.5 for every K with nu2(K + 9) <= 50, without induction hypothesis *) | ||
| 2247 | Theorem E_low K U s v : 41 <= K -> K + 9 = s * 2 ^ v -> Nat.odd s = true -> v <= 50 -> 1 <= U -> | ||
| 2248 | exists b', CSplus (VFe K (U * 2 ^ (K + 5))) (Cst b'). | ||
| 2249 | Proof. | ||
| 2250 | intros HK Hks Hs Hv HU. | ||
| 2251 | destruct (Nat.le_gt_cases v 10) as [Hle|Hgt]. | ||
| 2252 | - apply endgame; [exact HK| |exact HU]. rewrite Hks. apply odd_not_mod2048; auto. | ||
| 2253 | - eapply nested; [exact Hks|exact Hs|lia|exact HU]. | ||
| 2254 | Qed. | ||
| 2257 | (* ===================================================================== *) | ||
| 2258 | (* 18. Counter words above a cut, and one closed-system step with a *) | ||
| 2259 | (* concrete low part and an arbitrary counter word above it. *) | ||
| 2260 | (* ===================================================================== *) | ||
| 2262 | Definition ctr (Yc : nat -> list unt) : Prop := forall n e, IncN e (Yc n) (Yc (n + e)). | ||
| 2264 | Lemma ctr_bin : ctr bin. | ||
| 2265 | Proof. intros n e. apply IncN_bin. Qed. | ||
| 2267 | Lemma vfl_nil m V : vfl [] m V = digits m V ++ uP :: bin (V / 2 ^ m). | ||
| 2268 | Proof. | ||
| 2269 | revert V; induction m as [|m IH]; intros V. | ||
| 2270 | - cbn [vfl digits app]. rewrite Nat.pow_0_r, Nat.div_1_r. reflexivity. | ||
| 2271 | - cbn [vfl digits app hd tl]. rewrite IH. rewrite Nat.Div0.div_div, <- Nat.pow_succ_r'. reflexivity. | ||
| 2272 | Qed. | ||
| 2274 | Lemma ctr_vfl m : ctr (vfl [] m). | ||
| 2275 | Proof. | ||
| 2276 | intros n e. rewrite !vfl_nil. apply IncN_digits. apply IncN_P. | ||
| 2277 | replace ((n + e) / 2 ^ m) with (n / 2 ^ m + (n mod 2 ^ m + e) / 2 ^ m). | ||
| 2278 | - apply IncN_bin. | ||
| 2279 | - pose proof (Nat.pow_nonzero 2 m ltac:(lia)). | ||
| 2280 | assert (E : n + e = (n mod 2 ^ m + e) + (n / 2 ^ m) * 2 ^ m) by (pose proof (Nat.div_mod_eq n (2 ^ m)); lia). | ||
| 2281 | rewrite E, Nat.div_add by lia. lia. | ||
| 2282 | Qed. | ||
| 2284 | Lemma astep X Yc n D j T0 e1 A X1 X3 : | ||
| 2285 | ctr Yc -> | ||
| 2286 | XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true -> | ||
| 2287 | T0 <= D + pj j -> | ||
| 2288 | shiftX (fill X1 (val X1 + (D + pj j + 3 * A - T0))) = Some X3 -> | ||
| 2289 | cs_step (X ++ Yc n) D j | ||
| 2290 | (X3 ++ Yc (n + (e1 + (val X1 + (D + pj j + 3 * A - T0)) / 2 ^ ndig X1))) (D + A) (S j). | ||
| 2291 | Proof. | ||
| 2292 | intros HY H1 Hd Hc HT Hs. | ||
| 2293 | apply (cutstep X (Yc n) T0 e1 A X1 (D + pj j) ((val X1 + (D + pj j + 3 * A - T0)) / 2 ^ ndig X1) | ||
| 2294 | (fill X1 (val X1 + (D + pj j + 3 * A - T0))) D j | ||
| 2295 | (X3 ++ Yc (n + (e1 + (val X1 + (D + pj j + 3 * A - T0)) / 2 ^ ndig X1))) | ||
| 2296 | (Yc (n + (e1 + (val X1 + (D + pj j + 3 * A - T0)) / 2 ^ ndig X1))) H1 Hd). | ||
| 2297 | - apply (XN_clean X1 (D + pj j + 3 * A - T0) Hc). | ||
| 2298 | - exact HT. | ||
| 2299 | - reflexivity. | ||
| 2300 | - apply HY. | ||
| 2301 | - apply shiftX_app. exact Hs. | ||
| 2302 | Qed. | ||
| 2304 | (* ===================================================================== *) | ||
| 2305 | (* 19. Splitting value forms at a cut. *) | ||
| 2306 | (* ===================================================================== *) | ||
| 2308 | Lemma vlow_L hs L L' R V : R < L -> R < L' -> vlow hs L R V = vlow hs L' R V. | ||
| 2309 | Proof. | ||
| 2310 | revert hs L L' V; induction R as [|R IH]; intros hs L L' V H1 H2. | ||
| 2311 | - destruct L, L'; try lia. reflexivity. | ||
| 2312 | - destruct L as [|L], L' as [|L']; try lia. cbn [vlow]. rewrite (IH (tl hs) L L' (V / 2)) by lia. reflexivity. | ||
| 2313 | Qed. | ||
| 2315 | Lemma vfl_split_hi hs L R V : R < L -> length hs <= R -> | ||
| 2316 | vfl hs L V = vlow hs L R V ++ vfl [] (L - R) (V / 2 ^ R). | ||
| 2317 | Proof. | ||
| 2318 | revert hs L V; induction R as [|R IH]; intros hs L V HL Hh. | ||
| 2319 | - destruct hs; [|cbn in Hh; lia]. destruct L as [|L]; [lia|]. | ||
| 2320 | cbn [vlow app]. rewrite Nat.sub_0_r, Nat.pow_0_r, Nat.div_1_r. reflexivity. | ||
| 2321 | - destruct L as [|L]; [lia|]. cbn [vfl vlow]. rewrite <- app_assoc. cbn [app]. | ||
| 2322 | rewrite (IH (tl hs) L (V / 2)) by (try lia; destruct hs; cbn in *; lia). | ||
| 2323 | replace (S L - S R) with (L - R) by lia. | ||
| 2324 | rewrite Nat.Div0.div_div, <- Nat.pow_succ_r'. reflexivity. | ||
| 2325 | Qed. | ||
| 2327 | Lemma vfl_split_le hs L R V : L <= R -> 2 ^ R <= V -> vfl hs L V = vlow hs L R V ++ bin (V / 2 ^ R). | ||
| 2328 | Proof. | ||
| 2329 | revert hs R V; induction L as [|L IH]; intros hs R V HL HV. | ||
| 2330 | - cbn [vfl vlow app]. f_equal. apply digits_bin_split. exact HV. | ||
| 2331 | - destruct R as [|R]; [lia|]. cbn [vfl vlow]. rewrite <- app_assoc. cbn [app]. f_equal. f_equal. | ||
| 2332 | rewrite (IH (tl hs) R (V / 2)) by (try lia; rewrite Nat.pow_succ_r' in HV; apply Nat.div_le_lower_bound; lia). | ||
| 2333 | f_equal. f_equal. rewrite Nat.Div0.div_div. rewrite Nat.pow_succ_r'. reflexivity. | ||
| 2334 | Qed. | ||
| 2336 | Lemma lsteqb_eq a b : lsteqb a b = true -> a = b. | ||
| 2337 | Proof. unfold lsteqb. destruct (list_eq_dec unt_eq_dec a b); [auto|discriminate]. Qed. | ||
| 2339 | (* ===================================================================== *) | ||
| 2340 | (* 20. One descent step of a value form (Lemma VS of proof.md 6.3), *) | ||
| 2341 | (* symbolic in Omega, off and the marker height: the check runs the *) | ||
| 2342 | (* first T0 = 4096 carries on the low 8 digits (with the heads, and *) | ||
| 2343 | (* the marker when L <= 8), the rest of the carry phase by counter *) | ||
| 2344 | (* arithmetic on residues, and the absorption shift; the identities *) | ||
| 2345 | (* on the coefficients of Omega, off and 2^(L-1) make the next state *) | ||
| 2346 | (* the next value form for every member. *) | ||
| 2347 | (* ===================================================================== *) | ||
| 2349 | Definition vzf (r : vrow) (o L : nat) (low : bool) : Z := | ||
| 2350 | (Z.of_nat (val_ r * o + vwp r) - Z.of_nat (vwn r) - (if low then Z.of_nat (3 * 2 ^ (L - 1)) else 0))%Z. | ||
| 2352 | Definition vt0 (r : vrow) (off0 a : nat) (X1 : list unt) : Z := | ||
| 2353 | (Z.of_nat (val X1 + off0 + pj off0 + 3 * a) - Z.of_nat (64 + vd r + 4096))%Z. | ||
| 2355 | Definition vsrun (r : vrow) (off0 Lc : nat) : option (list unt * N * nat * list unt * list unt) := | ||
| 2356 | match xfeed 4000 4096 (vlowN (vh r) Lc 8 (Z.to_N (vzf r off0 Lc (Nat.leb Lc 8) mod 256))) with | ||
| 2357 | | None => None | ||
| 2358 | | Some (Xt, e1) => | ||
| 2359 | match splitP Xt with | ||
| 2360 | | (a, X1) => | ||
| 2361 | match shiftX (fillN X1 (Z.to_N (vt0 r off0 a X1 mod 2 ^ Z.of_nat (ndig X1)))) with | ||
| 2362 | | None => None | ||
| 2363 | | Some X3 => Some (Xt, e1, a, X1, X3) | ||
| 2364 | end | ||
| 2365 | end | ||
| 2366 | end. | ||
| 2368 | Definition vscond (fx : bool) (r r' : vrow) (off0 Lc : nat) (e1 : N) (a : nat) (X1 X3 : list unt) : bool := | ||
| 2369 | let low := Nat.leb Lc 8 in | ||
| 2370 | let L2 := if low then Lc + ndig X3 - 8 else S (ndig X3) in | ||
| 2371 | dhead X1 && allb cleanu X1 && Nat.leb 5 Lc && Nat.leb Lc 9 && | ||
| 2372 | Nat.eqb (vlam r' + 8) (vlam r + 1 + ndig X3) && Nat.eqb (vd r' + a) (vd r + 1) && | ||
| 2373 | Nat.leb (length (vh r')) (ndig X3) && Nat.leb (length (vh r)) 8 && Nat.leb 9 (Lc + ndig X3) && | ||
| 2374 | Nat.leb (ndig X1) 8 && Nat.leb (ndig X3) 8 && Nat.leb 1 L2 && Nat.leb L2 (if low then ndig X3 else S (ndig X3)) && | ||
| 2375 | lsteqb X3 (vlowN (vh r') L2 (ndig X3) (Z.to_N (vzf r' (S off0) L2 low mod 2 ^ Z.of_nat (ndig X3)))) && | ||
| 2376 | Z.eqb (vzf r off0 Lc low / 256 + Z.of_N e1 + vt0 r off0 a X1 / 2 ^ Z.of_nat (ndig X1)) | ||
| 2377 | (vzf r' (S off0) L2 low / 2 ^ Z.of_nat (ndig X3)) && | ||
| 2378 | Nat.eqb (vmu r + 2 ^ (8 - ndig X1)) (vmu r' * 2 ^ (8 - ndig X3)) && | ||
| 2379 | (fx || Nat.eqb (val_ r + 2 ^ (8 - ndig X1)) (val_ r' * 2 ^ (8 - ndig X3))). | ||
| 2381 | Definition vsok (fx : bool) (r r' : vrow) (off0 Lc : nat) : bool := | ||
| 2382 | match vsrun r off0 Lc with | ||
| 2383 | | Some (Xt, e1, a, X1, X3) => vscond fx r r' off0 Lc e1 a X1 X3 | ||
| 2384 | | None => false | ||
| 2385 | end. | ||
| 2387 | Lemma vsrun_spec r off0 Lc Xt e1 a X1 X3 : vsrun r off0 Lc = Some (Xt, e1, a, X1, X3) -> | ||
| 2388 | xfeed 4000 4096 (vlowN (vh r) Lc 8 (Z.to_N (vzf r off0 Lc (Nat.leb Lc 8) mod 256))) = Some (Xt, e1) /\ | ||
| 2389 | splitP Xt = (a, X1) /\ | ||
| 2390 | shiftX (fillN X1 (Z.to_N (vt0 r off0 a X1 mod 2 ^ Z.of_nat (ndig X1)))) = Some X3. | ||
| 2391 | Proof. | ||
| 2392 | unfold vsrun. | ||
| 2393 | destruct (xfeed 4000 4096 (vlowN (vh r) Lc 8 (Z.to_N (vzf r off0 Lc (Nat.leb Lc 8) mod 256)))) as [[Xt' e1']|]; | ||
| 2394 | [|discriminate]. | ||
| 2395 | destruct (splitP Xt') as [a' X1'] eqn:ES. | ||
| 2396 | destruct (shiftX (fillN X1' (Z.to_N (vt0 r off0 a' X1' mod 2 ^ Z.of_nat (ndig X1'))))) as [X3'|] eqn:Es; | ||
| 2397 | [|discriminate]. | ||
| 2398 | intros H. injection H as <- <- <- <- <-. auto. | ||
| 2399 | Qed. | ||
| 2401 | Lemma Zdm (z : Z) (m : nat) : 0 < m -> z = (Z.of_nat m * (z / Z.of_nat m) + z mod Z.of_nat m)%Z /\ | ||
| 2402 | (0 <= z mod Z.of_nat m < Z.of_nat m)%Z. | ||
| 2403 | Proof. intros H. split; [apply Z.div_mod; lia | apply Z.mod_pos_bound; lia]. Qed. | ||
| 2405 | Lemma pj_shift8 off0 a : a mod 8 = O -> pj (off0 + a) = pj off0. | ||
| 2406 | Proof. | ||
| 2407 | intros Ha. rewrite (pj_mod (off0 + a)), (pj_mod off0). f_equal. | ||
| 2408 | rewrite Nat.Div0.add_mod, Ha, Nat.add_0_r, Nat.Div0.mod_mod. reflexivity. | ||
| 2409 | Qed. | ||
| 2411 | Lemma vs_core r r' L V L' V' X0 Yc n n' D j e1 A X1 r2 M2 X3 : | ||
| 2412 | ctr Yc -> | ||
| 2413 | vfl (vh r) L V = X0 ++ Yc n -> vfl (vh r') L' V' = X3 ++ Yc n' -> | ||
| 2414 | XN 4096 X0 e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true -> | ||
| 2415 | 4096 <= D + pj j -> val X1 + (D + pj j + 3 * A - 4096) = r2 + 2 ^ ndig X1 * M2 -> r2 < 2 ^ ndig X1 -> | ||
| 2416 | shiftX (fill X1 r2) = Some X3 -> n' = n + (e1 + M2) -> | ||
| 2417 | cs_step (vfl (vh r) L V) D j (vfl (vh r') L' V') (D + A) (S j). | ||
| 2418 | Proof. | ||
| 2419 | intros HY Hz Hz' HX Hd Hc HT Hm Hr Hs Hn. | ||
| 2420 | rewrite Hz, Hz'. | ||
| 2421 | assert (E2 : (val X1 + (D + pj j + 3 * A - 4096)) / 2 ^ ndig X1 = M2). | ||
| 2422 | { rewrite Hm, div_mod_shift, Nat.div_small by exact Hr. lia. } | ||
| 2423 | assert (Hs' : shiftX (fill X1 (val X1 + (D + pj j + 3 * A - 4096))) = Some X3). | ||
| 2424 | { rewrite Hm, fill_mod. exact Hs. } | ||
| 2425 | pose proof (astep X0 Yc n D j 4096 e1 A X1 X3 HY HX Hd Hc HT Hs') as H. | ||
| 2426 | rewrite E2, <- Hn in H. exact H. | ||
| 2427 | Qed. | ||
| 2429 | Lemma Zpow_nat n : (2 ^ Z.of_nat n)%Z = Z.of_nat (2 ^ n). | ||
| 2430 | Proof. rewrite Nat2Z.inj_pow. reflexivity. Qed. | ||
| 2432 | Lemma pow_split n : n <= 8 -> 2 ^ n * 2 ^ (8 - n) = 256. | ||
| 2433 | Proof. intros H. rewrite <- Nat.pow_add_r. replace (n + (8 - n)) with 8 by lia. reflexivity. Qed. | ||
| 2435 | (* the arithmetic of one descent step, on plain numbers *) | ||
| 2436 | Lemma ar_main (mu al wp wn mu' al' wp' wn' w g off0 lc lc2 hc P1 P3 Pn Pn3 PL PL' vX p a vdr : nat) | ||
| 2437 | (e1 : N) (vz vz2 t0 : Z) : | ||
| 2438 | vz = (Z.of_nat (al * off0 + wp) - Z.of_nat wn - Z.of_nat lc)%Z -> | ||
| 2439 | vz2 = (Z.of_nat (al' * S off0 + wp') - Z.of_nat wn' - Z.of_nat lc2)%Z -> | ||
| 2440 | 3 * PL = lc + 768 * hc -> 3 * PL' = lc2 + 3 * Pn3 * hc -> | ||
| 2441 | Pn * P1 = 256 -> Pn3 * P3 = 256 -> 0 < Pn -> 0 < Pn3 -> | ||
| 2442 | t0 = (Z.of_nat (vX + off0 + p + 3 * a) - Z.of_nat (64 + vdr + 4096))%Z -> | ||
| 2443 | (vz / 256 + Z.of_N e1 + t0 / Z.of_nat Pn = vz2 / Z.of_nat Pn3)%Z -> | ||
| 2444 | mu + P1 = mu' * P3 -> (al + P1 = al' * P3 \/ g = O) -> | ||
| 2445 | wn + 3 * PL + 256 <= mu * (256 * w) + al * (off0 + 256 * g) + wp -> | ||
| 2446 | 4096 + 64 + vdr <= 256 * w + (off0 + 256 * g) -> | ||
| 2447 | 4096 <= 256 * w + (off0 + 256 * g) - 64 - vdr + p -> | ||
| 2448 | exists Qn M2 Q'n, | ||
| 2449 | mu * (256 * w) + al * (off0 + 256 * g) + wp - (wn + 3 * PL) = Z.to_nat (vz mod 256) + 256 * Qn /\ | ||
| 2450 | Z.to_nat (vz mod 256) < 256 /\ 1 <= Qn /\ | ||
| 2451 | vX + (256 * w + (off0 + 256 * g) - 64 - vdr + p + 3 * a - 4096) = Z.to_nat (t0 mod Z.of_nat Pn) + Pn * M2 /\ | ||
| 2452 | Z.to_nat (t0 mod Z.of_nat Pn) < Pn /\ | ||
| 2453 | mu' * (256 * w) + al' * S (off0 + 256 * g) + wp' - (wn' + 3 * PL') = | ||
| 2454 | Z.to_nat (vz2 mod Z.of_nat Pn3) + Pn3 * Q'n /\ | ||
| 2455 | Z.to_nat (vz2 mod Z.of_nat Pn3) < Pn3 /\ | ||
| 2456 | Q'n = Qn + (N.to_nat e1 + M2). | ||
| 2457 | Proof. | ||
| 2458 | intros Hvz Hvz2 HPL HPL' HPn HPn3 Hp Hp3 Ht0 Hq Hmu Hal HV Hc HT. | ||
| 2459 | destruct (Zdm vz 256 ltac:(lia)) as [Ev Bv]. change (Z.of_nat 256) with 256%Z in Ev, Bv. | ||
| 2460 | destruct (Zdm t0 Pn Hp) as [Et Bt]. destruct (Zdm vz2 Pn3 Hp3) as [Ev2 Bv2]. | ||
| 2461 | set (Qz := (vz / 256 + Z.of_nat (mu * w + al * g) - 3 * Z.of_nat hc)%Z). | ||
| 2462 | set (M2z := (t0 / Z.of_nat Pn + Z.of_nat P1 * Z.of_nat (w + g))%Z). | ||
| 2463 | set (Q'z := (vz2 / Z.of_nat Pn3 + Z.of_nat P3 * Z.of_nat (mu' * w + al' * g) - 3 * Z.of_nat hc)%Z). | ||
| 2464 | assert (EV : Z.of_nat (mu * (256 * w) + al * (off0 + 256 * g) + wp - (wn + 3 * PL)) = (vz mod 256 + 256 * Qz)%Z). | ||
| 2465 | { unfold Qz. clear -Hvz HPL HV Ev. lia. } | ||
| 2466 | assert (HQ : (1 <= Qz)%Z) by (clear -EV HV Bv; lia). | ||
| 2467 | assert (E256 : (Z.of_nat Pn * (Z.of_nat P1 * Z.of_nat (w + g)) = 256 * Z.of_nat (w + g))%Z). | ||
| 2468 | { rewrite Z.mul_assoc, <- Nat2Z.inj_mul, HPn. reflexivity. } | ||
| 2469 | assert (ET : Z.of_nat (vX + (256 * w + (off0 + 256 * g) - 64 - vdr + p + 3 * a - 4096)) = | ||
| 2470 | (t0 mod Z.of_nat Pn + Z.of_nat Pn * M2z)%Z). | ||
| 2471 | { unfold M2z. rewrite Z.mul_add_distr_l, E256. clear -Ht0 Hc HT Et. lia. } | ||
| 2472 | assert (HM : (0 <= M2z)%Z). | ||
| 2473 | { assert ((0 <= Z.of_nat (vX + (256 * w + (off0 + 256 * g) - 64 - vdr + p + 3 * a - 4096)))%Z) by lia. | ||
| 2474 | clear -ET Bt H Hp. nia. } | ||
| 2475 | assert (E256' : (Z.of_nat Pn3 * (Z.of_nat P3 * Z.of_nat (mu' * w + al' * g)) = 256 * Z.of_nat (mu' * w + al' * g))%Z). | ||
| 2476 | { rewrite Z.mul_assoc, <- Nat2Z.inj_mul, HPn3. reflexivity. } | ||
| 2477 | assert (EV' : (Z.of_nat (mu' * (256 * w) + al' * S (off0 + 256 * g) + wp') - Z.of_nat (wn' + 3 * PL') = | ||
| 2478 | vz2 mod Z.of_nat Pn3 + Z.of_nat Pn3 * Q'z)%Z). | ||
| 2479 | { unfold Q'z. rewrite Z.mul_sub_distr_l, Z.mul_add_distr_l, E256'. | ||
| 2480 | assert ((Z.of_nat (3 * PL') = Z.of_nat lc2 + 3 * (Z.of_nat Pn3 * Z.of_nat hc))%Z) by (rewrite HPL'; lia). | ||
| 2481 | clear -Hvz2 H Ev2. lia. } | ||
| 2482 | assert (HQQ : Q'z = (Qz + Z.of_N e1 + M2z)%Z). | ||
| 2483 | { unfold Q'z, Qz, M2z. | ||
| 2484 | assert (Hm1 : (Z.of_nat P3 * Z.of_nat (mu' * w) = Z.of_nat (mu * w + P1 * w))%Z). | ||
| 2485 | { rewrite <- Nat2Z.inj_mul. f_equal. replace (mu * w + P1 * w) with ((mu + P1) * w) by ring. | ||
| 2486 | rewrite Hmu. ring. } | ||
| 2487 | assert (Hm2 : (Z.of_nat P3 * Z.of_nat (al' * g) = Z.of_nat (al * g + P1 * g))%Z). | ||
| 2488 | { rewrite <- Nat2Z.inj_mul. f_equal. destruct Hal as [Hal|Hal]. | ||
| 2489 | - replace (al * g + P1 * g) with ((al + P1) * g) by ring. rewrite Hal. ring. | ||
| 2490 | - subst g. ring. } | ||
| 2491 | rewrite Nat2Z.inj_add, Z.mul_add_distr_l, Hm1, Hm2. | ||
| 2492 | clear -Hq. rewrite <- Hq. lia. } | ||
| 2493 | exists (Z.to_nat Qz), (Z.to_nat M2z), (Z.to_nat Q'z). | ||
| 2494 | assert (HQ' : (1 <= Q'z)%Z) by (rewrite HQQ; clear -HQ HM; lia). | ||
| 2495 | split; [|split; [|split; [|split; [|split; [|split; [|split]]]]]]. | ||
| 2496 | - apply Nat2Z.inj. rewrite EV, Nat2Z.inj_add, Nat2Z.inj_mul, !Z2Nat.id by lia. reflexivity. | ||
| 2497 | - lia. | ||
| 2498 | - lia. | ||
| 2499 | - apply Nat2Z.inj. rewrite ET, Nat2Z.inj_add, Nat2Z.inj_mul, !Z2Nat.id by lia. reflexivity. | ||
| 2500 | - lia. | ||
| 2501 | - apply Nat2Z.inj. rewrite Nat2Z.inj_sub. | ||
| 2502 | + rewrite EV', Nat2Z.inj_add, Nat2Z.inj_mul, !Z2Nat.id by lia. reflexivity. | ||
| 2503 | + apply Nat2Z.inj_le. clear -EV' Bv2 HQ' Hp3. nia. | ||
| 2504 | - lia. | ||
| 2505 | - rewrite HQQ. apply Nat2Z.inj. rewrite !Nat2Z.inj_add, N_nat_Z, !Z2Nat.id by lia. lia. | ||
| 2506 | Qed. | ||
| 2508 | Lemma ar_pj w g off0 : off0 < 256 -> 4160 <= 256 * w + (off0 + 256 * g) -> | ||
| 2509 | pj (256 * w + (off0 + 256 * g) - 64) = pj off0. | ||
| 2510 | Proof. | ||
| 2511 | intros H1 H2. replace (256 * w + (off0 + 256 * g) - 64) with (off0 + (32 * w + 32 * g - 8) * 8) by lia. | ||
| 2512 | apply pj_shift8. apply Nat.Div0.mod_mul. | ||
| 2513 | Qed. | ||
| 2515 | Lemma if_true A (x y : A) : (if true then x else y) = x. | ||
| 2516 | Proof. reflexivity. Qed. | ||
| 2518 | Lemma if_false A (x y : A) : (if false then x else y) = y. | ||
| 2519 | Proof. reflexivity. Qed. | ||
| 2521 | Lemma vs_gen fx r r' off0 Lc g w k off : | ||
| 2522 | vsok fx r r' off0 Lc = true -> off0 < 256 -> | ||
| 2523 | off = off0 + 256 * g -> (fx = true -> g = O) -> | ||
| 2524 | (Lc <= 8 /\ k + vlam r - off = Lc \/ Lc = 9 /\ 9 <= k + vlam r - off) -> | ||
| 2525 | vwn r + 3 * 2 ^ (k + vlam r - off - 1) + 256 <= vmu r * (256 * w) + val_ r * off + vwp r -> | ||
| 2526 | 4096 + 64 + vd r <= 256 * w + off -> | ||
| 2527 | CS (vfz r k (256 * w) off) (vfz r' k (256 * w) (S off)). | ||
| 2528 | Proof. | ||
| 2529 | intros Hok Ho0 Hoff Hfx HLc HV Hc. subst off. | ||
| 2530 | (* PITFALL: destructing [vsrun ..] inside the hypothesis makes Qed hang; destruct in the goal *) | ||
| 2531 | revert Hok. unfold vsok. | ||
| 2532 | destruct (vsrun r off0 Lc) as [[[[[Xt e1] a] X1] X3]|] eqn:Er; [|intros Hok; discriminate Hok]. | ||
| 2533 | intros Hok. | ||
| 2534 | destruct (vsrun_spec _ _ _ _ _ _ _ _ Er) as [Ex [ES Es]]. clear Er. | ||
| 2535 | unfold vscond in Hok. | ||
| 2536 | repeat rewrite Bool.andb_true_iff in Hok. | ||
| 2537 | destruct Hok as [[[[[[[[[[[[[[[[Hd Hcl] H5] H9] Hlam] Hvd] Hlh'] Hlh] H9n] Hnd] Hnd3] HL21] HL22] HX3] Hq] Hmu] Hal]. | ||
| 2538 | apply Nat.leb_le in H5, H9, Hlh', Hlh, H9n, Hnd, Hnd3, HL21, HL22. | ||
| 2539 | apply Nat.eqb_eq in Hlam, Hvd, Hmu. | ||
| 2540 | apply lsteqb_eq in HX3. apply Z.eqb_eq in Hq. | ||
| 2541 | assert (Hal' : val_ r + 2 ^ (8 - ndig X1) = val_ r' * 2 ^ (8 - ndig X3) \/ g = O). | ||
| 2542 | { destruct fx; [right; apply Hfx; reflexivity | left; apply Nat.eqb_eq; exact Hal]. } | ||
| 2543 | clear Hal. | ||
| 2544 | apply xfeed_sound in Ex. change (N.to_nat 4096) with 4096%nat in Ex. | ||
| 2545 | pose proof (splitP_spec Xt) as HS. rewrite ES in HS. destruct HS as [EXt _]. rewrite EXt in Ex. | ||
| 2546 | rewrite fillN_spec, Z_N_nat in Es. rewrite vlowN_spec, Z_N_nat in Ex, HX3. | ||
| 2547 | rewrite (Zpow_nat (ndig X1)) in Es, Hq. rewrite (Zpow_nat (ndig X3)) in Hq, HX3. | ||
| 2548 | set (t0 := vt0 r off0 a X1) in *. | ||
| 2549 | set (vz := vzf r off0 Lc (Nat.leb Lc 8)) in *. | ||
| 2550 | set (L2 := if Nat.leb Lc 8 then Lc + ndig X3 - 8 else S (ndig X3)) in *. | ||
| 2551 | set (vz2 := vzf r' (S off0) L2 (Nat.leb Lc 8)) in *. | ||
| 2552 | assert (HPn : 2 ^ ndig X1 * 2 ^ (8 - ndig X1) = 256) by (apply pow_split; exact Hnd). | ||
| 2553 | assert (HPn3 : 2 ^ ndig X3 * 2 ^ (8 - ndig X3) = 256) by (apply pow_split; exact Hnd3). | ||
| 2554 | assert (Pn_pos : 0 < 2 ^ ndig X1) by (apply Nat.neq_0_lt_0, Nat.pow_nonzero; lia). | ||
| 2555 | assert (Pn3_pos : 0 < 2 ^ ndig X3) by (apply Nat.neq_0_lt_0, Nat.pow_nonzero; lia). | ||
| 2556 | set (j := 256 * w + (off0 + 256 * g) - 64). | ||
| 2557 | assert (Hpj : pj j = pj off0) by (apply ar_pj; [exact Ho0|clear -Hc; lia]). | ||
| 2558 | assert (HT : 4096 <= 256 * w + (off0 + 256 * g) - 64 - vd r + pj off0) by (clear -Hc; lia). | ||
| 2559 | assert (HT' : 4096 <= j - vd r + pj j) by (rewrite Hpj; exact HT). | ||
| 2560 | unfold CS, vfz. cbn [fst snd]. fold j. | ||
| 2561 | replace (256 * w + S (off0 + 256 * g) - 64 - vd r') with (j - vd r + a) by (clear -Hvd Hc; unfold j; lia). | ||
| 2562 | replace (256 * w + S (off0 + 256 * g) - 64) with (S j) by (clear -Hc; unfold j; lia). | ||
| 2563 | set (L := k + vlam r - (off0 + 256 * g)) in *. | ||
| 2564 | set (L' := k + vlam r' - S (off0 + 256 * g)). | ||
| 2565 | assert (EL' : L' = L + ndig X3 - 8) by (clear -Hlam HLc H5 H9n; unfold L', L; lia). | ||
| 2566 | set (V := vmu r * (256 * w) + val_ r * (off0 + 256 * g) + vwp r - (vwn r + 3 * 2 ^ (L - 1))). | ||
| 2567 | set (V' := vmu r' * (256 * w) + val_ r' * S (off0 + 256 * g) + vwp r' - (vwn r' + 3 * 2 ^ (L' - 1))). | ||
| 2568 | destruct HLc as [[HLc HL]|[HLc HL]]. | ||
| 2569 | - (* marker below the cut: the upper part is bin *) | ||
| 2570 | assert (Elow : Nat.leb Lc 8 = true) by (apply Nat.leb_le; exact HLc). | ||
| 2571 | assert (EL2 : L2 = Lc + ndig X3 - 8) by (unfold L2; rewrite Elow; reflexivity). | ||
| 2572 | destruct (ar_main (vmu r) (val_ r) (vwp r) (vwn r) (vmu r') (val_ r') (vwp r') (vwn r') w g off0 | ||
| 2573 | (3 * 2 ^ (Lc - 1)) (3 * 2 ^ (L2 - 1)) 0 (2 ^ (8 - ndig X1)) (2 ^ (8 - ndig X3)) | ||
| 2574 | (2 ^ ndig X1) (2 ^ ndig X3) (2 ^ (L - 1)) (2 ^ (L' - 1)) (val X1) (pj off0) a (vd r) e1 vz vz2 t0) | ||
| 2575 | as [Qn [M2 [Q'n [EV [Bv [HQ [ET [Bt [EV' [Bv' EQ]]]]]]]]]]. | ||
| 2576 | + unfold vz, vzf. rewrite Elow. reflexivity. | ||
| 2577 | + unfold vz2, vzf. rewrite Elow. reflexivity. | ||
| 2578 | + rewrite HL. lia. | ||
| 2579 | + replace L' with L2 by (rewrite EL', EL2, HL; reflexivity). lia. | ||
| 2580 | + exact HPn. | ||
| 2581 | + exact HPn3. | ||
| 2582 | + exact Pn_pos. | ||
| 2583 | + exact Pn3_pos. | ||
| 2584 | + unfold t0, vt0. reflexivity. | ||
| 2585 | + exact Hq. | ||
| 2586 | + exact Hmu. | ||
| 2587 | + exact Hal'. | ||
| 2588 | + exact HV. | ||
| 2589 | + exact Hc. | ||
| 2590 | + exact HT. | ||
| 2591 | + fold V in EV. fold V' in EV'. | ||
| 2592 | set (v0n := Z.to_nat (vz mod 256)) in *. set (r2n := Z.to_nat (t0 mod Z.of_nat (2 ^ ndig X1))) in *. | ||
| 2593 | set (v02n := Z.to_nat (vz2 mod Z.of_nat (2 ^ ndig X3))) in *. | ||
| 2594 | clearbody v0n r2n v02n. clear Hq Hmu Hal'. | ||
| 2595 | assert (Hz : vfl (vh r) L V = vlow (vh r) Lc 8 v0n ++ bin Qn). | ||
| 2596 | { rewrite (vfl_split_le (vh r) L 8 V) by (change (2 ^ 8) with 256; lia). | ||
| 2597 | rewrite EV. change 256 with (2 ^ 8). rewrite vlow_mod, div_mod_shift, Nat.div_small by exact Bv. | ||
| 2598 | rewrite HL. reflexivity. } | ||
| 2599 | assert (Hz' : vfl (vh r') L' V' = X3 ++ bin Q'n). | ||
| 2600 | { rewrite (vfl_split_le (vh r') L' (ndig X3) V'). | ||
| 2601 | - rewrite EV', vlow_mod, div_mod_shift, Nat.div_small, Nat.add_0_l by exact Bv'. | ||
| 2602 | replace L' with L2 by (rewrite EL', EL2, HL; reflexivity). rewrite <- HX3. reflexivity. | ||
| 2603 | - rewrite EL', HL. rewrite EL2 in HL22. rewrite Elow in HL22. lia. | ||
| 2604 | - rewrite EV'. nia. } | ||
| 2605 | eapply (vs_core r r' L V L' V' _ bin Qn Q'n (j - vd r) j (N.to_nat e1) a X1 _ M2 X3 ctr_bin Hz Hz' Ex Hd Hcl HT'). | ||
| 2606 | * rewrite Hpj. unfold j. exact ET. | ||
| 2607 | * exact Bt. | ||
| 2608 | * exact Es. | ||
| 2609 | * exact EQ. | ||
| 2610 | - (* marker above the cut: the upper part is a digit word with the marker *) | ||
| 2611 | assert (Ehi : Nat.leb Lc 8 = false) by (apply Nat.leb_gt; lia). | ||
| 2612 | assert (EL2 : L2 = S (ndig X3)) by (unfold L2; rewrite Ehi; reflexivity). | ||
| 2613 | subst Lc. | ||
| 2614 | destruct (ar_main (vmu r) (val_ r) (vwp r) (vwn r) (vmu r') (val_ r') (vwp r') (vwn r') w g off0 | ||
| 2615 | 0 0 (2 ^ (L - 9)) (2 ^ (8 - ndig X1)) (2 ^ (8 - ndig X3)) | ||
| 2616 | (2 ^ ndig X1) (2 ^ ndig X3) (2 ^ (L - 1)) (2 ^ (L' - 1)) (val X1) (pj off0) a (vd r) e1 vz vz2 t0) | ||
| 2617 | as [Qn [M2 [Q'n [EV [Bv [HQ [ET [Bt [EV' [Bv' EQ]]]]]]]]]]. | ||
| 2618 | + unfold vz, vzf. rewrite Ehi. reflexivity. | ||
| 2619 | + unfold vz2, vzf. rewrite Ehi. reflexivity. | ||
| 2620 | + replace (L - 1) with (8 + (L - 9)) by lia. rewrite Nat.pow_add_r. change (2 ^ 8) with 256. lia. | ||
| 2621 | + replace (L' - 1) with (ndig X3 + (L - 9)) by lia. rewrite Nat.pow_add_r. lia. | ||
| 2622 | + exact HPn. | ||
| 2623 | + exact HPn3. | ||
| 2624 | + exact Pn_pos. | ||
| 2625 | + exact Pn3_pos. | ||
| 2626 | + unfold t0, vt0. reflexivity. | ||
| 2627 | + exact Hq. | ||
| 2628 | + exact Hmu. | ||
| 2629 | + exact Hal'. | ||
| 2630 | + exact HV. | ||
| 2631 | + exact Hc. | ||
| 2632 | + exact HT. | ||
| 2633 | + fold V in EV. fold V' in EV'. | ||
| 2634 | set (v0n := Z.to_nat (vz mod 256)) in *. set (r2n := Z.to_nat (t0 mod Z.of_nat (2 ^ ndig X1))) in *. | ||
| 2635 | set (v02n := Z.to_nat (vz2 mod Z.of_nat (2 ^ ndig X3))) in *. | ||
| 2636 | clearbody v0n r2n v02n. clear Hq Hmu Hal'. | ||
| 2637 | assert (Hz : vfl (vh r) L V = vlow (vh r) 9 8 v0n ++ vfl [] (L - 8) Qn). | ||
| 2638 | { rewrite (vfl_split_hi (vh r) L 8 V) by lia. | ||
| 2639 | rewrite (vlow_L (vh r) L 9 8 V) by lia. | ||
| 2640 | rewrite EV. change 256 with (2 ^ 8). rewrite vlow_mod, div_mod_shift, Nat.div_small by exact Bv. | ||
| 2641 | reflexivity. } | ||
| 2642 | assert (Hz' : vfl (vh r') L' V' = X3 ++ vfl [] (L - 8) Q'n). | ||
| 2643 | { rewrite (vfl_split_hi (vh r') L' (ndig X3) V') by lia. | ||
| 2644 | replace (L' - ndig X3) with (L - 8) by lia. | ||
| 2645 | rewrite (vlow_L (vh r') L' (S (ndig X3)) (ndig X3) V') by lia. | ||
| 2646 | rewrite EV', vlow_mod, div_mod_shift, Nat.div_small, Nat.add_0_l by exact Bv'. | ||
| 2647 | rewrite <- EL2, <- HX3. reflexivity. } | ||
| 2648 | eapply (vs_core r r' L V L' V' _ (vfl [] (L - 8)) Qn Q'n (j - vd r) j (N.to_nat e1) a X1 _ M2 X3 | ||
| 2649 | (ctr_vfl (L - 8)) Hz Hz' Ex Hd Hcl HT'). | ||
| 2650 | * rewrite Hpj. unfold j. exact ET. | ||
| 2651 | * exact Bt. | ||
| 2652 | * exact Es. | ||
| 2653 | * exact EQ. | ||
| 2654 | Qed. | ||
| 2656 | (* ===================================================================== *) | ||
| 2657 | (* 21. The value-form tables (proof.md 6.2): the entry table for level 1 *) | ||
| 2658 | (* at off 20..31 and the phase table elsewhere; the finite checks. *) | ||
| 2659 | (* ===================================================================== *) | ||
| 2661 | Definition enrows : list vrow := | ||
| 2662 | [ mkV [[]; [uS1]] 24 1 0 0 0 2; | ||
| 2663 | mkV [[]; [uSP]] 25 2 0 0 0 3; | ||
| 2664 | mkV [[uS1; uP; uP]] 24 1 0 0 2 4; | ||
| 2665 | mkV [[]; []; []; [uS1]] 24 1 0 0 0 2; | ||
| 2666 | mkV [[]; []; [uS1; uP]] 24 1 0 0 4 3; | ||
| 2667 | mkV [[]; []; [uSP; uP]] 25 2 0 0 4 4; | ||
| 2668 | mkV [[uS1]; [uP; uP; uP]] 24 1 0 0 4 5; | ||
| 2669 | mkV [[uS1; uP; uP; uP]] 24 1 0 1 0 5; | ||
| 2670 | mkV [[uS1]] 24 1 0 8 0 2; | ||
| 2671 | mkV [[]; []; [uS1]] 24 1 0 8 0 2; | ||
| 2672 | mkV [[]; [uS1; uP]] 24 1 0 6 0 3; | ||
| 2673 | mkV [[uS1; uP; uP]] 24 1 0 7 0 4 ]. | ||
| 2675 | Definition row1 (off : nat) : vrow := | ||
| 2676 | if Nat.leb off 31 then nth (off - 20) enrows (phrow 0) else phrow (off mod 8). | ||
| 2678 | Definition en_ok (i : nat) : bool := vsok true (row1 (20 + i)) (row1 (21 + i)) (20 + i) 9. | ||
| 2680 | Definition lcs : list nat := [5%nat; 6; 7; 8; 9]. | ||
| 2682 | Definition ph_ok (o : nat) : bool := | ||
| 2683 | forallb (fun Lc => vsok false (phrow (o mod 8)) (phrow (S o mod 8)) o Lc) lcs. | ||
| 2685 | (* PITFALL: state the vm_compute facts over named predicates; a named | ||
| 2686 | [Definition x := forallb (fun ..) ..] makes the kernel evaluate the | ||
| 2687 | checks lazily when it is unfolded in a conversion *) | ||
| 2688 | (* the kernel must unfold these before vsok, or it evaluates vsok lazily *) | ||
| 2689 | Strategy expand [en_ok ph_ok]. | ||
| 2691 | Lemma en_all : forallb en_ok (upto 12) = true. | ||
| 2692 | Proof. vm_compute. reflexivity. Qed. | ||
| 2694 | Lemma ph_all : forallb ph_ok (upto 256) = true. | ||
| 2695 | Proof. vm_compute. reflexivity. Qed. | ||
| 2697 | (* bounds on the rows *) | ||
| 2698 | Definition rowok (r : vrow) : bool := | ||
| 2699 | Nat.leb 1 (vmu r) && Nat.leb (vwn r) 42 && Nat.leb (vd r) 5 && Nat.leb 24 (vlam r) && Nat.leb (vlam r) 25. | ||
| 2701 | Lemma nth_rowok l d n : forallb rowok l = true -> rowok d = true -> rowok (nth n l d) = true. | ||
| 2702 | Proof. | ||
| 2703 | revert n; induction l as [|x l IH]; intros n H Hd; destruct n; cbn in *; auto; | ||
| 2704 | apply andb_prop in H; destruct H; auto. | ||
| 2705 | Qed. | ||
| 2707 | Lemma phrow_ok phi : rowok (phrow phi) = true. | ||
| 2708 | Proof. unfold phrow. apply nth_rowok; reflexivity. Qed. | ||
| 2710 | Lemma row1_ok off : rowok (row1 off) = true. | ||
| 2711 | Proof. unfold row1. destruct (Nat.leb off 31); [apply nth_rowok; [reflexivity|apply phrow_ok]|apply phrow_ok]. Qed. | ||
| 2713 | Lemma rowok_spec r : rowok r = true -> 1 <= vmu r /\ vwn r <= 42 /\ vd r <= 5 /\ 24 <= vlam r <= 25. | ||
| 2714 | Proof. | ||
| 2715 | unfold rowok. intros H. repeat rewrite Bool.andb_true_iff in H. | ||
| 2716 | destruct H as [[[[H1 H2] H3] H4] H5]. apply Nat.leb_le in H1, H2, H3, H4, H5. lia. | ||
| 2717 | Qed. | ||
| 2719 | Lemma row1_lam off : 20 <= off -> vlam (row1 off) <= off + 4. | ||
| 2720 | Proof. | ||
| 2721 | intros H. destruct (Nat.le_gt_cases off 31) as [Hle|Hgt]. | ||
| 2722 | - assert (E : off = 20 + (off - 20)) by lia. rewrite E. | ||
| 2723 | assert (Hi : off - 20 < 12) by lia. | ||
| 2724 | generalize (off - 20) Hi. clear. intros i Hi. | ||
| 2725 | assert (Hc : forallb (fun i => Nat.leb (vlam (row1 (20 + i))) (20 + i + 4)) (upto 12) = true) by reflexivity. | ||
| 2726 | rewrite forallb_forall in Hc. apply Nat.leb_le. apply Hc. apply upto_In. exact Hi. | ||
| 2727 | - destruct (rowok_spec _ (row1_ok off)). lia. | ||
| 2728 | Qed. | ||
| 2730 | Lemma mod8_256 off : (off mod 256) mod 8 = off mod 8. | ||
| 2731 | Proof. | ||
| 2732 | rewrite (Nat.div_mod_eq off 256) at 2. | ||
| 2733 | replace (256 * (off / 256) + off mod 256) with (off mod 256 + (32 * (off / 256)) * 8) by lia. | ||
| 2734 | rewrite Nat.Div0.mod_add. reflexivity. | ||
| 2735 | Qed. | ||
| 2737 | Lemma Smod8_256 off : S (off mod 256) mod 8 = S off mod 8. | ||
| 2738 | Proof. | ||
| 2739 | rewrite (Nat.div_mod_eq off 256) at 2. | ||
| 2740 | replace (S (256 * (off / 256) + off mod 256)) with (S (off mod 256) + (32 * (off / 256)) * 8) by lia. | ||
| 2741 | rewrite Nat.Div0.mod_add. reflexivity. | ||
| 2742 | Qed. | ||
| 2744 | (* PITFALL: rewriting inside a hypothesis that mentions vsok makes Qed hang; | ||
| 2745 | take the boolean facts as plain terms and rewrite only goals *) | ||
| 2746 | Lemma en_at i : i < 12 -> vsok true (row1 (20 + i)) (row1 (21 + i)) (20 + i) 9 = true. | ||
| 2747 | Proof. intros Hi. exact (proj1 (forallb_forall en_ok (upto 12)) en_all i (upto_In _ _ Hi)). Qed. | ||
| 2749 | Lemma ph_at o Lc : o < 256 -> In Lc lcs -> vsok false (phrow (o mod 8)) (phrow (S o mod 8)) o Lc = true. | ||
| 2750 | Proof. | ||
| 2751 | intros Ho HL. | ||
| 2752 | exact (proj1 (forallb_forall (fun Lc => vsok false (phrow (o mod 8)) (phrow (S o mod 8)) o Lc) lcs) | ||
| 2753 | (proj1 (forallb_forall ph_ok (upto 256)) ph_all o (upto_In _ _ Ho)) Lc HL). | ||
| 2754 | Qed. | ||
| 2756 | (* one descent step with a phase row *) | ||
| 2757 | Lemma vs_ph k w off : | ||
| 2758 | 5 <= k + vlam (phrow (off mod 8)) - off -> | ||
| 2759 | vwn (phrow (off mod 8)) + 3 * 2 ^ (k + vlam (phrow (off mod 8)) - off - 1) + 256 <= | ||
| 2760 | vmu (phrow (off mod 8)) * (256 * w) + val_ (phrow (off mod 8)) * off + vwp (phrow (off mod 8)) -> | ||
| 2761 | 4096 + 64 + vd (phrow (off mod 8)) <= 256 * w + off -> | ||
| 2762 | CS (vfz (phrow (off mod 8)) k (256 * w) off) (vfz (phrow (S off mod 8)) k (256 * w) (S off)). | ||
| 2763 | Proof. | ||
| 2764 | intros HL HV Hc. | ||
| 2765 | set (L := k + vlam (phrow (off mod 8)) - off) in *. | ||
| 2766 | set (Lc := if Nat.leb L 8 then L else 9). | ||
| 2767 | assert (HLc : In Lc lcs) by (unfold Lc, lcs; destruct (Nat.leb_spec L 8); cbn; lia). | ||
| 2768 | assert (Ho : off mod 256 < 256) by (apply Nat.mod_upper_bound; lia). | ||
| 2769 | rewrite <- (mod8_256 off), <- (Smod8_256 off). | ||
| 2770 | apply (vs_gen false _ _ (off mod 256) Lc (off / 256) w k off (ph_at _ _ Ho HLc) Ho). | ||
| 2771 | - pose proof (Nat.div_mod_eq off 256). lia. | ||
| 2772 | - discriminate. | ||
| 2773 | - rewrite mod8_256. unfold Lc. fold L. destruct (Nat.leb_spec L 8); [left|right]; lia. | ||
| 2774 | - rewrite mod8_256. exact HV. | ||
| 2775 | - rewrite mod8_256. exact Hc. | ||
| 2776 | Qed. | ||
| 2778 | (* one descent step with an entry row (level 1, off 20..31) *) | ||
| 2779 | Lemma vs_en k w off : | ||
| 2780 | 20 <= off <= 31 -> 9 <= k + vlam (row1 off) - off -> | ||
| 2781 | vwn (row1 off) + 3 * 2 ^ (k + vlam (row1 off) - off - 1) + 256 <= | ||
| 2782 | vmu (row1 off) * (256 * w) + val_ (row1 off) * off + vwp (row1 off) -> | ||
| 2783 | 4096 + 64 + vd (row1 off) <= 256 * w + off -> | ||
| 2784 | CS (vfz (row1 off) k (256 * w) off) (vfz (row1 (S off)) k (256 * w) (S off)). | ||
| 2785 | Proof. | ||
| 2786 | intros Ho HL HV Hc. | ||
| 2787 | assert (Hi : off - 20 < 12) by lia. | ||
| 2788 | assert (E : off = 20 + (off - 20)) by lia. | ||
| 2789 | remember (off - 20) as i eqn:Ei. clear Ei. subst off. | ||
| 2790 | apply (vs_gen true (row1 (20 + i)) (row1 (21 + i)) (20 + i) 9 0 w k (20 + i) (en_at i Hi)); lia. | ||
| 2791 | Qed. | ||
| 2793 | Inductive CSstar : st -> st -> Prop := | ||
| 2794 | | CSs0 s : CSstar s s | ||
| 2795 | | CSsS s s1 s' : CS s s1 -> CSstar s1 s' -> CSstar s s'. | ||
| 2797 | Lemma CSstar_snoc a b c : CSstar a b -> CS b c -> CSstar a c. | ||
| 2798 | Proof. | ||
| 2799 | intros H1. induction H1 as [s|s s1 s' Hs H1 IH]; intros H2. | ||
| 2800 | - econstructor; [exact H2|constructor]. | ||
| 2801 | - econstructor; [exact Hs|]. apply IH. exact H2. | ||
| 2802 | Qed. | ||
| 2804 | Lemma CSstar_plus a b c : CSstar a b -> CSplus b c -> CSplus a c. | ||
| 2805 | Proof. | ||
| 2806 | intros H1. induction H1 as [s|s s1 s' Hs H1 IH]; intros H2. | ||
| 2807 | - exact H2. | ||
| 2808 | - eapply CSpS; [exact Hs|]. apply IH. exact H2. | ||
| 2809 | Qed. | ||
| 2811 | Lemma descent (rowf : nat -> vrow) k Om a b : | ||
| 2812 | (forall x, a <= x < b -> CS (vfz (rowf x) k Om x) (vfz (rowf (S x)) k Om (S x))) -> a <= b -> | ||
| 2813 | CSstar (vfz (rowf a) k Om a) (vfz (rowf b) k Om b). | ||
| 2814 | Proof. | ||
| 2815 | intros H Hab. replace b with (a + (b - a)) by lia. | ||
| 2816 | assert (Hn : forall n, a + n <= b -> CSstar (vfz (rowf a) k Om a) (vfz (rowf (a + n)) k Om (a + n))). | ||
| 2817 | { induction n as [|n IH]; intros Hn. | ||
| 2818 | - rewrite Nat.add_0_r. constructor. | ||
| 2819 | - eapply CSstar_snoc; [apply IH; lia|]. replace (a + S n) with (S (a + n)) by lia. apply H. lia. } | ||
| 2820 | apply Hn. lia. | ||
| 2821 | Qed. | ||
| 2823 | (* ===================================================================== *) | ||
| 2824 | (* 22. Lemma VF (proof.md 6.3): the value form is carried from off 20 *) | ||
| 2825 | (* (level 1) or off' 17 (level 2) down to off_end. *) | ||
| 2826 | (* ===================================================================== *) | ||
| 2828 | Lemma off_end_L5 k x l : x < off_end k -> 24 <= l -> (x = k + 20 -> l = 25) -> 5 <= k + l - x. | ||
| 2829 | Proof. | ||
| 2830 | unfold off_end. intros Hx Hl H25. | ||
| 2831 | destruct (Nat.eqb ((k + 20) mod 8) 3); [|lia]. | ||
| 2832 | destruct (Nat.eq_dec x (k + 20)) as [E|E]; [specialize (H25 E); lia|lia]. | ||
| 2833 | Qed. | ||
| 2835 | Lemma off_end_phase3 k x : x < off_end k -> x = k + 20 -> x mod 8 = 3. | ||
| 2836 | Proof. | ||
| 2837 | unfold off_end. intros Hx E. subst x. | ||
| 2838 | destruct (Nat.eqb_spec ((k + 20) mod 8) 3); [assumption|lia]. | ||
| 2839 | Qed. | ||
| 2841 | Lemma pow_ge k a : a <= k -> 2 ^ a <= 2 ^ k. | ||
| 2842 | Proof. intros H. apply Nat.pow_le_mono_r; lia. Qed. | ||
| 2844 | Theorem VF1 k o : 41 <= k -> 1 <= o -> | ||
| 2845 | CSstar (vfz (row1 20) k (o * 2 ^ (k + 5)) 20) (VFe k (o * 2 ^ (k + 5))). | ||
| 2846 | Proof. | ||
| 2847 | intros Hk Ho. | ||
| 2848 | set (T := 2 ^ (k + 3)). | ||
| 2849 | assert (HT : 4096 <= T) by (unfold T; change 4096 with (2 ^ 12); apply pow_ge; lia). | ||
| 2850 | set (w := o * 2 ^ (k - 3)). | ||
| 2851 | assert (Ew : o * 2 ^ (k + 5) = 256 * w). | ||
| 2852 | { unfold w. replace (k + 5) with (8 + (k - 3)) by lia. rewrite Nat.pow_add_r. change (2 ^ 8) with 256. lia. } | ||
| 2853 | assert (Ew' : 256 * w = o * (4 * T)). | ||
| 2854 | { rewrite <- Ew. unfold T. replace (k + 5) with (2 + (k + 3)) by lia. rewrite Nat.pow_add_r. reflexivity. } | ||
| 2855 | rewrite Ew. unfold VFe. | ||
| 2856 | assert (Hend : 61 <= off_end k) by (unfold off_end; destruct (Nat.eqb _ _); lia). | ||
| 2857 | assert (Er : phrow (off_end k mod 8) = row1 (off_end k)). | ||
| 2858 | { unfold row1. replace (Nat.leb (off_end k) 31) with false; [reflexivity|symmetry; apply Nat.leb_gt; lia]. } | ||
| 2859 | rewrite Er. | ||
| 2860 | apply descent; [|lia]. | ||
| 2861 | intros x Hx. | ||
| 2862 | destruct (rowok_spec _ (row1_ok x)) as [Hmu [Hwn [Hvd [Hl1 Hl2]]]]. | ||
| 2863 | assert (HLx : vlam (row1 x) <= x + 4) by (apply row1_lam; lia). | ||
| 2864 | assert (HL5 : 5 <= k + vlam (row1 x) - x). | ||
| 2865 | { apply off_end_L5; [lia|lia|]. intros E. | ||
| 2866 | assert (E3 := off_end_phase3 k x ltac:(lia) E). | ||
| 2867 | unfold row1. replace (Nat.leb x 31) with false by (symmetry; apply Nat.leb_gt; lia). | ||
| 2868 | rewrite E3. reflexivity. } | ||
| 2869 | assert (HP : 2 ^ (k + vlam (row1 x) - x - 1) <= T) by (unfold T; apply pow_ge; lia). | ||
| 2870 | assert (Hm : 256 * w <= vmu (row1 x) * (256 * w)) by nia. | ||
| 2871 | assert (HV : vwn (row1 x) + 3 * 2 ^ (k + vlam (row1 x) - x - 1) + 256 <= | ||
| 2872 | vmu (row1 x) * (256 * w) + val_ (row1 x) * x + vwp (row1 x)) by nia. | ||
| 2873 | assert (Hc : 4096 + 64 + vd (row1 x) <= 256 * w + x) by nia. | ||
| 2874 | destruct (Nat.le_gt_cases x 31) as [Hle|Hgt]. | ||
| 2875 | - apply vs_en; [lia|lia|exact HV|exact Hc]. | ||
| 2876 | - assert (E1 : row1 x = phrow (x mod 8)). | ||
| 2877 | { unfold row1. replace (Nat.leb x 31) with false by (symmetry; apply Nat.leb_gt; lia). reflexivity. } | ||
| 2878 | assert (E2 : row1 (S x) = phrow (S x mod 8)). | ||
| 2879 | { unfold row1. replace (Nat.leb (S x) 31) with false by (symmetry; apply Nat.leb_gt; lia). reflexivity. } | ||
| 2880 | rewrite E1, E2. rewrite E1 in HL5, HV, Hc. apply vs_ph; assumption. | ||
| 2881 | Qed. | ||
| 2883 | Theorem VF2 v S : 12 <= v -> 2 <= S -> | ||
| 2884 | CSstar (vfz (phrow 1) (v - 10) (S * 2 ^ v) 17) (VFe (v - 10) (S * 2 ^ v)). | ||
| 2885 | Proof. | ||
| 2886 | intros Hv HS. | ||
| 2887 | set (k := v - 10). | ||
| 2888 | set (T := 2 ^ (v - 3)). | ||
| 2889 | assert (HT : 512 <= T) by (unfold T; change 512 with (2 ^ 9); apply pow_ge; lia). | ||
| 2890 | set (w := S * 2 ^ (v - 8)). | ||
| 2891 | assert (Ew : S * 2 ^ v = 256 * w). | ||
| 2892 | { unfold w. replace v with (8 + (v - 8)) at 1 by lia. rewrite Nat.pow_add_r. change (2 ^ 8) with 256. lia. } | ||
| 2893 | assert (Ew' : 256 * w = S * (8 * T)). | ||
| 2894 | { rewrite <- Ew. unfold T. replace v with (3 + (v - 3)) at 1 by lia. rewrite Nat.pow_add_r. reflexivity. } | ||
| 2895 | rewrite Ew. unfold VFe. | ||
| 2896 | change (phrow 1) with (phrow (17 mod 8)). | ||
| 2897 | apply (descent (fun x => phrow (x mod 8))); [|unfold off_end; destruct (Nat.eqb _ _); lia]. | ||
| 2898 | intros x Hx. cbv beta. | ||
| 2899 | destruct (rowok_spec _ (phrow_ok (x mod 8))) as [Hmu [Hwn [Hvd [Hl1 Hl2]]]]. | ||
| 2900 | assert (HL5 : 5 <= k + vlam (phrow (x mod 8)) - x). | ||
| 2901 | { apply off_end_L5; [lia|lia|]. intros E. rewrite (off_end_phase3 k x ltac:(lia) E). reflexivity. } | ||
| 2902 | assert (HP : 2 ^ (k + vlam (phrow (x mod 8)) - x - 1) <= T) by (unfold T; apply pow_ge; unfold k; lia). | ||
| 2903 | assert (Hm : 256 * w <= vmu (phrow (x mod 8)) * (256 * w)) by nia. | ||
| 2904 | assert (HV : vwn (phrow (x mod 8)) + 3 * 2 ^ (k + vlam (phrow (x mod 8)) - x - 1) + 256 <= | ||
| 2905 | vmu (phrow (x mod 8)) * (256 * w) + val_ (phrow (x mod 8)) * x + vwp (phrow (x mod 8))) by nia. | ||
| 2906 | assert (Hc : 4096 + 64 + vd (phrow (x mod 8)) <= 256 * w + x) by nia. | ||
| 2907 | apply vs_ph; assumption. | ||
| 2908 | Qed. | ||
| 2912 | (* ===================================================================== *) | ||
| 2913 | (* 23. Lemma E (proof.md 6.1): C(b) at off 17 to the value form at 20. *) | ||
| 2914 | (* ===================================================================== *) | ||
| 2916 | Lemma bin_pow_odd i q : bin (2 ^ i * (2 * q + 1)) = repeat uD0 i ++ uD1 :: bin q. | ||
| 2917 | Proof. | ||
| 2918 | induction i as [|i IH]. | ||
| 2919 | - cbn [repeat app]. rewrite Nat.pow_0_r, Nat.mul_1_l. rewrite bin_pos by lia. | ||
| 2920 | rewrite dig_odd. f_equal. f_equal. | ||
| 2921 | replace (2 * q + 1) with (1 + q * 2) by lia. rewrite Nat.div_add by lia. reflexivity. | ||
| 2922 | - rewrite Nat.pow_succ_r'. rewrite bin_pos by (pose proof (Nat.pow_nonzero 2 i); nia). | ||
| 2923 | rewrite <- Nat.mul_assoc, dig_even. | ||
| 2924 | replace (2 * (2 ^ i * (2 * q + 1)) / 2) with (2 ^ i * (2 * q + 1)). | ||
| 2925 | + rewrite IH. reflexivity. | ||
| 2926 | + rewrite (Nat.mul_comm 2 (2 ^ i * (2 * q + 1))), Nat.div_mul by lia. reflexivity. | ||
| 2927 | Qed. | ||
| 2929 | Lemma shift_D0s m w : shift (repeat uD0 m ++ w) = | ||
| 2930 | match shift w with Some w' => Some (repeat uD0 m ++ w') | None => None end. | ||
| 2931 | Proof. | ||
| 2932 | induction m as [|m IH]; cbn [repeat app shift]; [destruct (shift w); reflexivity|]. | ||
| 2933 | rewrite IH. destruct (shift w); reflexivity. | ||
| 2934 | Qed. | ||
| 2936 | Lemma pj17 b : pj (32 * b + 17) = 48. | ||
| 2937 | Proof. | ||
| 2938 | rewrite pj_mod. replace (32 * b + 17) with (1 + (4 * b + 2) * 8) by lia. rewrite Nat.Div0.mod_add. reflexivity. | ||
| 2939 | Qed. | ||
| 2941 | Lemma cs_step_conv Z D j Z' D1 j1 D2 j2 : cs_step Z D j Z' D1 j1 -> D1 = D2 -> j1 = j2 -> cs_step Z D j Z' D2 j2. | ||
| 2942 | Proof. intros H -> ->. exact H. Qed. | ||
| 2944 | Lemma E1 k q : 41 <= k -> | ||
| 2945 | let b := (2 * q + 1) * 2 ^ k - 2 in | ||
| 2946 | CS (Cst b) (repeat uD0 (k + 6) ++ uS1 :: bin q, 32 * b + 17, 32 * b + 18). | ||
| 2947 | Proof. | ||
| 2948 | intros Hk b. | ||
| 2949 | set (o := 2 * q + 1) in *. | ||
| 2950 | set (P := 2 ^ (k - 3)). | ||
| 2951 | assert (HP : 2 ^ k = 8 * P) by (unfold P; replace k with (3 + (k - 3)) at 1 by lia; rewrite Nat.pow_add_r; reflexivity). | ||
| 2952 | assert (HP1 : 4096 <= P) by (unfold P; change 4096 with (2 ^ 12); apply pow_ge; lia). | ||
| 2953 | assert (Hb : b = 8 * o * P - 2) by (unfold b; rewrite HP; lia). | ||
| 2954 | unfold CS, Cst. cbn [fst snd]. | ||
| 2955 | (* the zone is S1 :: bin V17 with V17 = 256 oP - 2 *) | ||
| 2956 | assert (Ez : [uS1; uD0; uD1; uD1; uD1; uD1] ++ bin (S b) = | ||
| 2957 | [uS1; uD0; uD1; uD1; uD1; uD1; uD1; uD1; uD1] ++ bin (o * P - 1)). | ||
| 2958 | { change ([uS1; uD0; uD1; uD1; uD1; uD1] ++ bin (S b)) with (uS1 :: (digits 5 30 ++ bin (S b))). | ||
| 2959 | rewrite digits_app_bin by (cbn [Nat.pow Nat.mul Nat.add]; lia). | ||
| 2960 | rewrite (digits_bin_split 8) by (change (2 ^ 8) with 256; change (2 ^ 5) with 32; rewrite Hb; clear -HP1; nia). | ||
| 2961 | replace (30 + 2 ^ 5 * S b) with (254 + 2 ^ 8 * (o * P - 1)) by (rewrite Hb; change (2 ^ 5) with 32; change (2 ^ 8) with 256; clear -HP1; nia). | ||
| 2962 | rewrite digits_mod, div_mod_shift, Nat.div_small by (change (2 ^ 8) with 256; lia). | ||
| 2963 | reflexivity. } | ||
| 2964 | rewrite Ez. | ||
| 2965 | assert (Hx : xfeed 4000 4096 [uS1; uD0; uD1; uD1; uD1; uD1; uD1; uD1; uD1] = | ||
| 2966 | Some (uP :: [uD1; uD0; uD1; uD1; uD1; uD1; uD1; uD1], 16%N)) by reflexivity. | ||
| 2967 | apply xfeed_sound in Hx. change (N.to_nat 4096) with 4096%nat in Hx. change (N.to_nat 16) with 16%nat in Hx. | ||
| 2968 | set (X1 := [uD1; uD0; uD1; uD1; uD1; uD1; uD1; uD1]). | ||
| 2969 | assert (Hc : 32 * b + 16 + pj (32 * b + 17) = 256 * (o * P)) by (rewrite pj17, Hb; nia). | ||
| 2970 | pose proof (XN_clean X1 (32 * b + 16 + pj (32 * b + 17) + 3 * 1 - 4096) eq_refl) as H2. | ||
| 2971 | replace (val X1 + (32 * b + 16 + pj (32 * b + 17) + 3 * 1 - 4096)) with (0 + 2 ^ ndig X1 * (o * P - 15)) in H2 | ||
| 2972 | by (rewrite Hc; change (val X1) with 253; change (ndig X1) with 8; change (2 ^ 8) with 256; nia). | ||
| 2973 | rewrite fill_mod, div_mod_shift, Nat.Div0.div_0_l, Nat.add_0_l in H2. | ||
| 2974 | change (fill X1 0) with (repeat uD0 8) in H2. | ||
| 2975 | eapply cs_step_conv. | ||
| 2976 | { apply (cutstep [uS1; uD0; uD1; uD1; uD1; uD1; uD1; uD1; uD1] (bin (o * P - 1)) 4096 16 1 X1 | ||
| 2977 | (32 * b + 16 + pj (32 * b + 17)) (o * P - 15) (repeat uD0 8) (32 * b + 16) (32 * b + 17) _ | ||
| 2978 | (bin (2 ^ (k - 2) * (2 * q + 1))) Hx eq_refl H2). | ||
| 2979 | - rewrite Hc. nia. | ||
| 2980 | - reflexivity. | ||
| 2981 | - replace (2 ^ (k - 2) * (2 * q + 1)) with (o * P - 1 + (16 + (o * P - 15))). | ||
| 2982 | + apply IncN_bin. | ||
| 2983 | + unfold o, P. replace (k - 2) with (S (k - 3)) by lia. rewrite Nat.pow_succ_r'. fold P. nia. | ||
| 2984 | - rewrite shift_D0s, bin_pow_odd, shift_D0s. cbn [shift]. | ||
| 2985 | rewrite app_assoc, <- repeat_app. replace (8 + (k - 2)) with (k + 6) by lia. reflexivity. } | ||
| 2986 | - lia. | ||
| 2987 | - lia. | ||
| 2988 | Qed. | ||
| 2990 | Definition s1w (q : nat) : list unt := if Nat.eqb q 0 then [uS1] else uP :: bin (2 * q - 1). | ||
| 2992 | Lemma IncN_s1w q : IncN q (uS1 :: bin q) (s1w q). | ||
| 2993 | Proof. | ||
| 2994 | unfold s1w. destruct q as [|q]; [constructor|]. cbn [Nat.eqb]. | ||
| 2995 | econstructor; [constructor|]. apply IncN_P. | ||
| 2996 | replace (2 * S q - 1) with (S q + q) by lia. apply IncN_bin. | ||
| 2997 | Qed. | ||
| 2999 | Lemma digits_pow2 i : digits (S i) (2 ^ i) = repeat uD0 i ++ [uD1]. | ||
| 3000 | Proof. | ||
| 3001 | induction i as [|i IH]; [reflexivity|]. | ||
| 3002 | change (digits (S (S i)) (2 ^ S i)) with (dig (2 ^ S i) :: digits (S i) (2 ^ S i / 2)). | ||
| 3003 | rewrite Nat.pow_succ_r', dig_even. rewrite Nat.mul_comm, Nat.div_mul by lia. rewrite IH. reflexivity. | ||
| 3004 | Qed. | ||
| 3006 | Lemma pj18 b : pj (32 * b + 18) = 48. | ||
| 3007 | Proof. | ||
| 3008 | rewrite pj_mod. replace (32 * b + 18) with (2 + (4 * b + 2) * 8) by lia. rewrite Nat.Div0.mod_add. reflexivity. | ||
| 3009 | Qed. | ||
| 3011 | Lemma odd_half q P : 0 < P -> (2 * q + 1) * P / (2 * P) = q. | ||
| 3012 | Proof. | ||
| 3013 | intros HP. symmetry. apply Nat.div_unique with P; lia. | ||
| 3014 | Qed. | ||
| 3016 | Lemma E2 k q : 41 <= k -> | ||
| 3017 | let b := (2 * q + 1) * 2 ^ k - 2 in | ||
| 3018 | CS (repeat uD0 (k + 6) ++ uS1 :: bin q, 32 * b + 17, 32 * b + 18) | ||
| 3019 | (uS1 :: repeat uD0 (k + 4) ++ uD1 :: s1w q, 32 * b + 17, 32 * b + 19). | ||
| 3020 | Proof. | ||
| 3021 | intros Hk b. | ||
| 3022 | set (o := 2 * q + 1) in *. | ||
| 3023 | set (P := 2 ^ (k - 3)). | ||
| 3024 | assert (HP : 2 ^ k = 8 * P) by (unfold P; replace k with (3 + (k - 3)) at 1 by lia; rewrite Nat.pow_add_r; reflexivity). | ||
| 3025 | assert (HP1 : 4096 <= P) by (unfold P; change 4096 with (2 ^ 12); apply pow_ge; lia). | ||
| 3026 | assert (HP2 : 2 ^ (k - 2) = 2 * P) by (unfold P; replace (k - 2) with (S (k - 3)) by lia; apply Nat.pow_succ_r'). | ||
| 3027 | assert (Hb : b = 8 * o * P - 2) by (unfold b; rewrite HP; lia). | ||
| 3028 | unfold CS. cbn [fst snd]. | ||
| 3029 | replace (repeat uD0 (k + 6)) with (repeat uD0 8 ++ digits (k - 2) 0). | ||
| 3030 | 2:{ replace (digits (k - 2) 0) with (repeat uD0 (k - 2)). | ||
| 3031 | - rewrite <- repeat_app. f_equal. lia. | ||
| 3032 | - generalize (k - 2). intros n. induction n as [|n IH]; [reflexivity|]. cbn [repeat digits]. rewrite IH. reflexivity. } | ||
| 3033 | rewrite <- app_assoc. | ||
| 3034 | assert (Hx : xfeed 4000 4096 (repeat uD0 8) = Some (repeat uD0 8, 16%N)) by reflexivity. | ||
| 3035 | apply xfeed_sound in Hx. change (N.to_nat 4096) with 4096%nat in Hx. change (N.to_nat 16) with 16%nat in Hx. | ||
| 3036 | assert (Hc : 32 * b + 17 + pj (32 * b + 18) = 256 * (o * P) + 1) by (rewrite pj18, Hb; nia). | ||
| 3037 | pose proof (XN_clean (repeat uD0 8) (32 * b + 17 + pj (32 * b + 18) + 3 * 0 - 4096) eq_refl) as H2. | ||
| 3038 | replace (val (repeat uD0 8) + (32 * b + 17 + pj (32 * b + 18) + 3 * 0 - 4096)) | ||
| 3039 | with (1 + 2 ^ ndig (repeat uD0 8) * (o * P - 16)) in H2 | ||
| 3040 | by (rewrite Hc; change (val (repeat uD0 8)) with O; change (ndig (repeat uD0 8)) with 8; change (2 ^ 8) with 256; nia). | ||
| 3041 | rewrite fill_mod, div_mod_shift, Nat.div_small in H2 by (change (ndig (repeat uD0 8)) with 8; cbn; lia). | ||
| 3042 | change (fill (repeat uD0 8) 1) with [uD1; uD0; uD0; uD0; uD0; uD0; uD0; uD0] in H2. | ||
| 3043 | eapply cs_step_conv. | ||
| 3044 | { apply (cutstep (repeat uD0 8) (digits (k - 2) 0 ++ uS1 :: bin q) 4096 16 0 (repeat uD0 8) | ||
| 3045 | (32 * b + 17 + pj (32 * b + 18)) (0 + (o * P - 16)) [uD1; uD0; uD0; uD0; uD0; uD0; uD0; uD0] | ||
| 3046 | (32 * b + 17) (32 * b + 18) _ (digits (k - 2) (0 + o * P) ++ s1w q) Hx eq_refl H2). | ||
| 3047 | - rewrite Hc. nia. | ||
| 3048 | - reflexivity. | ||
| 3049 | - replace (16 + (0 + (o * P - 16))) with (o * P) by nia. | ||
| 3050 | apply IncN_digits. rewrite Nat.Div0.mod_0_l, Nat.add_0_l, HP2. unfold o. rewrite odd_half by lia. | ||
| 3051 | apply IncN_s1w. | ||
| 3052 | - rewrite (shiftX_app [uD1; uD0; uD0; uD0; uD0; uD0; uD0; uD0] [uS1; uD0; uD0; uD0; uD0; uD0; uD0; uD0]) by reflexivity. | ||
| 3053 | f_equal. | ||
| 3054 | replace (0 + o * P) with (P + 2 ^ (k - 2) * q) by (rewrite HP2; unfold o; lia). | ||
| 3055 | rewrite digits_mod. replace (k - 2) with (S (k - 3)) by lia. unfold P. rewrite digits_pow2. | ||
| 3056 | cbn [app]. f_equal. | ||
| 3057 | replace (k + 4) with (7 + (k - 3)) by lia. rewrite repeat_app. cbn [repeat app]. | ||
| 3058 | rewrite <- app_assoc. cbn [app]. reflexivity. } | ||
| 3059 | - lia. | ||
| 3060 | - lia. | ||
| 3061 | Qed. | ||
| 3063 | Lemma pj19 b : pj (32 * b + 19) = 47. | ||
| 3064 | Proof. | ||
| 3065 | rewrite pj_mod. replace (32 * b + 19) with (3 + (4 * b + 2) * 8) by lia. rewrite Nat.Div0.mod_add. reflexivity. | ||
| 3066 | Qed. | ||
| 3068 | Lemma IncN_s1w_up q : IncN (2 * q + 1) (s1w q) (uP :: bin (4 * q)). | ||
| 3069 | Proof. | ||
| 3070 | unfold s1w. destruct q as [|q]; cbn [Nat.eqb]. | ||
| 3071 | - change (IncN 1 [uS1] [uP]). econstructor; [constructor|]. constructor. | ||
| 3072 | - apply IncN_P. replace (4 * S q) with (2 * S q - 1 + (2 * S q + 1)) by lia. apply IncN_bin. | ||
| 3073 | Qed. | ||
| 3075 | Lemma E3 k q : 41 <= k -> | ||
| 3076 | let b := (2 * q + 1) * 2 ^ k - 2 in | ||
| 3077 | CS (uS1 :: repeat uD0 (k + 4) ++ uD1 :: s1w q, 32 * b + 17, 32 * b + 19) | ||
| 3078 | ([uD0; uS1; uD0; uD0; uD0; uD0; uD0; uD0] ++ digits (k - 3) (2 ^ (k - 4)) ++ uP :: bin (4 * q), | ||
| 3079 | 32 * b + 18, 32 * b + 20). | ||
| 3080 | Proof. | ||
| 3081 | intros Hk b. | ||
| 3082 | set (o := 2 * q + 1) in *. | ||
| 3083 | set (P := 2 ^ (k - 3)). | ||
| 3084 | assert (HP : 2 ^ k = 8 * P) by (unfold P; replace k with (3 + (k - 3)) at 1 by lia; rewrite Nat.pow_add_r; reflexivity). | ||
| 3085 | assert (HP1 : 4096 <= P) by (unfold P; change 4096 with (2 ^ 12); apply pow_ge; lia). | ||
| 3086 | assert (HP4 : P = 2 * 2 ^ (k - 4)) by (unfold P; replace (k - 3) with (S (k - 4)) by lia; apply Nat.pow_succ_r'). | ||
| 3087 | assert (Hb : b = 8 * o * P - 2) by (unfold b; rewrite HP; lia). | ||
| 3088 | unfold CS. cbn [fst snd]. | ||
| 3089 | replace (uS1 :: repeat uD0 (k + 4) ++ uD1 :: s1w q) | ||
| 3090 | with ((uS1 :: repeat uD0 8) ++ digits (k - 3) (2 ^ (k - 4)) ++ s1w q). | ||
| 3091 | 2:{ replace (k - 3) with (S (k - 4)) by lia. rewrite digits_pow2. | ||
| 3092 | replace (k + 4) with (8 + (k - 4)) by lia. rewrite repeat_app. | ||
| 3093 | cbn [app]. rewrite <- !app_assoc. reflexivity. } | ||
| 3094 | assert (Hx : xfeed 4000 4096 (uS1 :: repeat uD0 8) = | ||
| 3095 | Some (uP :: [uD1; uD1; uD1; uD1; uD1; uD1; uD1; uD1], 15%N)) by reflexivity. | ||
| 3096 | apply xfeed_sound in Hx. change (N.to_nat 4096) with 4096%nat in Hx. change (N.to_nat 15) with 15%nat in Hx. | ||
| 3097 | set (X1 := [uD1; uD1; uD1; uD1; uD1; uD1; uD1; uD1]) in Hx. | ||
| 3098 | assert (Hc : 32 * b + 17 + pj (32 * b + 19) = 256 * (o * P)) by (rewrite pj19, Hb; nia). | ||
| 3099 | pose proof (XN_clean X1 (32 * b + 17 + pj (32 * b + 19) + 3 * 1 - 4096) eq_refl) as H2. | ||
| 3100 | replace (val X1 + (32 * b + 17 + pj (32 * b + 19) + 3 * 1 - 4096)) | ||
| 3101 | with (2 + 2 ^ ndig X1 * (o * P - 15)) in H2 | ||
| 3102 | by (rewrite Hc; change (val X1) with 255; change (ndig X1) with 8; change (2 ^ 8) with 256; nia). | ||
| 3103 | rewrite fill_mod, div_mod_shift, Nat.div_small in H2 by (change (ndig X1) with 8; cbn; lia). | ||
| 3104 | change (fill X1 2) with [uD0; uD1; uD0; uD0; uD0; uD0; uD0; uD0] in H2. | ||
| 3105 | eapply cs_step_conv. | ||
| 3106 | { apply (cutstep (uS1 :: repeat uD0 8) (digits (k - 3) (2 ^ (k - 4)) ++ s1w q) 4096 15 1 X1 | ||
| 3107 | (32 * b + 17 + pj (32 * b + 19)) (0 + (o * P - 15)) [uD0; uD1; uD0; uD0; uD0; uD0; uD0; uD0] | ||
| 3108 | (32 * b + 17) (32 * b + 19) _ (digits (k - 3) (2 ^ (k - 4) + o * P) ++ uP :: bin (4 * q)) Hx eq_refl H2). | ||
| 3109 | - rewrite Hc. nia. | ||
| 3110 | - reflexivity. | ||
| 3111 | - replace (15 + (0 + (o * P - 15))) with (o * P) by nia. | ||
| 3112 | apply IncN_digits. fold P. | ||
| 3113 | replace ((2 ^ (k - 4) mod P + o * P) / P) with (2 * q + 1). | ||
| 3114 | + apply IncN_s1w_up. | ||
| 3115 | + rewrite Nat.mod_small by lia. apply Nat.div_unique with (2 ^ (k - 4)); unfold o; lia. | ||
| 3116 | - rewrite (shiftX_app [uD0; uD1; uD0; uD0; uD0; uD0; uD0; uD0] [uD0; uS1; uD0; uD0; uD0; uD0; uD0; uD0]) by reflexivity. | ||
| 3117 | f_equal. f_equal. | ||
| 3118 | replace (2 ^ (k - 4) + o * P) with (2 ^ (k - 4) + 2 ^ (k - 3) * o) by (unfold P; lia). | ||
| 3119 | rewrite digits_mod. reflexivity. } | ||
| 3120 | - lia. | ||
| 3121 | - lia. | ||
| 3122 | Qed. | ||
| 3124 | (* the off 20 form of Lemma E is the level-1 value form at off 20 *) | ||
| 3125 | Lemma vfl_row20 m W : vfl [[]; [uS1]] (S (S m)) (4 * W) = uD0 :: uS1 :: uD0 :: vfl [] m W. | ||
| 3126 | Proof. | ||
| 3127 | cbn [vfl hd tl app]. | ||
| 3128 | replace (4 * W) with (2 * (2 * W)) by lia. rewrite dig_even. | ||
| 3129 | rewrite (Nat.mul_comm 2 (2 * W)), Nat.div_mul by lia. rewrite dig_even. | ||
| 3130 | rewrite (Nat.mul_comm 2 W), Nat.div_mul by lia. reflexivity. | ||
| 3131 | Qed. | ||
| 3133 | Lemma E_id k q : 41 <= k -> | ||
| 3134 | let b := (2 * q + 1) * 2 ^ k - 2 in | ||
| 3135 | ([uD0; uS1; uD0; uD0; uD0; uD0; uD0; uD0] ++ digits (k - 3) (2 ^ (k - 4)) ++ uP :: bin (4 * q), | ||
| 3136 | 32 * b + 18, 32 * b + 20) = vfz (row1 20) k ((2 * q + 1) * 2 ^ (k + 5)) 20. | ||
| 3137 | Proof. | ||
| 3138 | intros Hk b. unfold b. | ||
| 3139 | assert (E5 : 2 ^ (k + 5) = 32 * 2 ^ k) by (rewrite Nat.pow_add_r; change (2 ^ 5) with 32; lia). | ||
| 3140 | assert (E3' : 2 ^ (k + 3) = 8 * 2 ^ k) by (rewrite Nat.pow_add_r; change (2 ^ 3) with 8; lia). | ||
| 3141 | assert (E2' : 2 ^ (k + 2) = 4 * 2 ^ k) by (rewrite Nat.pow_add_r; change (2 ^ 2) with 4; lia). | ||
| 3142 | assert (E1' : 2 ^ (k + 1) = 2 * 2 ^ k) by (rewrite Nat.pow_add_r; change (2 ^ 1) with 2; lia). | ||
| 3143 | assert (HK : 1 <= 2 ^ k) by (pose proof (Nat.pow_nonzero 2 k); lia). | ||
| 3144 | unfold vfz. change (row1 20) with (mkV [[]; [uS1]] 24 1 0 0 0 2). cbn [vlam vmu val_ vwp vwn vd vh]. | ||
| 3145 | replace (k + 24 - 20) with (S (S (k + 2))) by lia. | ||
| 3146 | replace (S (S (k + 2)) - 1) with (k + 3) by lia. | ||
| 3147 | match goal with |- context [vfl _ _ ?V] => | ||
| 3148 | replace V with (4 * (2 ^ (k + 1) + 2 ^ (k + 2) * (4 * q))) by (rewrite E5, E3', E2', E1'; nia) end. | ||
| 3149 | rewrite vfl_row20, vfl_nil, digits_mod. | ||
| 3150 | replace ((2 ^ (k + 1) + 2 ^ (k + 2) * (4 * q)) / 2 ^ (k + 2)) with (4 * q) | ||
| 3151 | by (apply Nat.div_unique with (2 ^ (k + 1)); rewrite ?E2', ?E1'; lia). | ||
| 3152 | replace (k + 2) with (S (k + 1)) by lia. rewrite digits_pow2. | ||
| 3153 | replace (k - 3) with (S (k - 4)) by lia. rewrite digits_pow2. | ||
| 3154 | replace (k + 1) with (5 + (k - 4)) by lia. rewrite repeat_app. | ||
| 3155 | assert (HK6 : 64 <= 2 ^ k) by (change 64 with (2 ^ 6); apply pow_ge; lia). | ||
| 3156 | f_equal; [f_equal|]; try (cbn [app repeat]; rewrite <- ?app_assoc; reflexivity); | ||
| 3157 | rewrite E5; clear -HK6; nia. | ||
| 3158 | Qed. | ||
| 3160 | (* Lemma E: C(b) reaches the level-1 value form at off 20 *) | ||
| 3161 | Theorem LemmaE k q : 41 <= k -> | ||
| 3162 | CSplus (Cst ((2 * q + 1) * 2 ^ k - 2)) (vfz (row1 20) k ((2 * q + 1) * 2 ^ (k + 5)) 20). | ||
| 3163 | Proof. | ||
| 3164 | intros Hk. | ||
| 3165 | eapply CSpS; [apply (E1 k q Hk)|]. | ||
| 3166 | eapply CSpS; [apply (E2 k q Hk)|]. | ||
| 3167 | apply CSp1. rewrite <- (E_id k q Hk). apply (E3 k q Hk). | ||
| 3168 | Qed. | ||
| 3171 | (* ===================================================================== *) | ||
| 3172 | (* 24. Lemma P (proof.md 6.5): the plant, off' 12 to off' 17. *) | ||
| 3173 | (* ===================================================================== *) | ||
| 3175 | Lemma pjg g i : pj (8 * g + i) = pj i. | ||
| 3176 | Proof. | ||
| 3177 | rewrite pj_mod, (pj_mod i). f_equal. replace (8 * g + i) with (i + g * 8) by lia. apply Nat.Div0.mod_add. | ||
| 3178 | Qed. | ||
| 3180 | Lemma digits_0 n : digits n 0 = repeat uD0 n. | ||
| 3181 | Proof. | ||
| 3182 | induction n as [|n IH]; [reflexivity|]. | ||
| 3183 | change (digits (S n) 0) with (dig 0 :: digits n (0 / 2)). change (0 / 2) with O. rewrite IH. reflexivity. | ||
| 3184 | Qed. | ||
| 3186 | Lemma digits_snoc m x : x < 2 ^ m -> digits (S m) x = digits m x ++ [uD0]. | ||
| 3187 | Proof. | ||
| 3188 | revert x; induction m as [|m IH]; intros x Hx. | ||
| 3189 | - cbn in Hx. assert (x = O) by lia. subst. reflexivity. | ||
| 3190 | - change (digits (S (S m)) x) with (dig x :: digits (S m) (x / 2)). | ||
| 3191 | rewrite IH. | ||
| 3192 | + reflexivity. | ||
| 3193 | + rewrite Nat.pow_succ_r' in Hx. apply Nat.Div0.div_lt_upper_bound. lia. | ||
| 3194 | Qed. | ||
| 3196 | (* t carries on an r-digit block holding v leave v' and pass p *) | ||
| 3197 | Lemma IncN_dig_q r v t p v' rest rest' : v' < 2 ^ r -> v + t = v' + 2 ^ r * p -> | ||
| 3198 | v < 2 ^ r -> IncN p rest rest' -> IncN t (digits r v ++ rest) (digits r v' ++ rest'). | ||
| 3199 | Proof. | ||
| 3200 | intros Hv' E Hv H. | ||
| 3201 | replace (digits r v') with (digits r (v + t)) by (rewrite E, digits_mod; reflexivity). | ||
| 3202 | apply IncN_digits. replace ((v mod 2 ^ r + t) / 2 ^ r) with p; [exact H|]. | ||
| 3203 | rewrite Nat.mod_small by exact Hv. rewrite E. rewrite div_mod_shift, Nat.div_small by exact Hv'. reflexivity. | ||
| 3204 | Qed. | ||
| 3206 | Lemma XN_clean_q X t vx nd x p : allb cleanu X = true -> val X = vx -> ndig X = nd -> | ||
| 3207 | x < 2 ^ nd -> vx + t = x + 2 ^ nd * p -> XN t X p (fill X x). | ||
| 3208 | Proof. | ||
| 3209 | intros Hc <- <- Hx E. pose proof (XN_clean X t Hc) as H. | ||
| 3210 | rewrite E, fill_mod, div_mod_shift, Nat.div_small in H by exact Hx. exact H. | ||
| 3211 | Qed. | ||
| 3213 | (* one closed-system step: a concrete low part X takes the first T0 carries | ||
| 3214 | (all drops), its clean rest X1 the remaining ones, Y the passed ones *) | ||
| 3215 | Lemma pstep X Y T0 e1 A X1 vx nd x p X3 Y' D j D' j' : | ||
| 3216 | XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true -> val X1 = vx -> ndig X1 = nd -> | ||
| 3217 | x < 2 ^ nd -> vx + (D + pj j + 3 * A - T0) = x + 2 ^ nd * p -> T0 <= D + pj j -> | ||
| 3218 | IncN (e1 + p) Y Y' -> shiftX (fill X1 x) = Some X3 -> D' = D + A -> j' = S j -> | ||
| 3219 | CS (X ++ Y, D, j) (X3 ++ Y', D', j'). | ||
| 3220 | Proof. | ||
| 3221 | intros H1 Hd Hc Ev En Hx E HT HY Hs -> ->. unfold CS; cbn [fst snd]. | ||
| 3222 | eapply (cutstep X Y T0 e1 A X1 (D + pj j) p (fill X1 x) D j (X3 ++ Y') Y' H1 Hd). | ||
| 3223 | - eapply XN_clean_q; eauto. | ||
| 3224 | - exact HT. | ||
| 3225 | - reflexivity. | ||
| 3226 | - exact HY. | ||
| 3227 | - apply shiftX_app. exact Hs. | ||
| 3228 | Qed. | ||
| 3230 | (* a step without drops on a zone with a digit at the bottom *) | ||
| 3231 | Lemma cs_nodrop Z D j Y Z' : dhead Z = true -> IncN (D + pj j) Z Y -> shift Y = Some Z' -> | ||
| 3232 | CS (Z, D, j) (Z', D, S j). | ||
| 3233 | Proof. | ||
| 3234 | intros Hd HI Hs. unfold CS; cbn [fst snd]. | ||
| 3235 | exists (D + pj j), O, Y. | ||
| 3236 | split; [exact HI|]. split; [apply dhead_notP; eapply IncN_dhead; eauto|]. split; [lia|]. split. | ||
| 3237 | - intros m' A' Y' Hm Hi HN. destruct A' as [|A']. | ||
| 3238 | + lia. | ||
| 3239 | + exfalso. pose proof (IncN_dhead _ _ _ Hd Hi) as H. cbn in H. discriminate. | ||
| 3240 | - split; [exact Hs|split; lia]. | ||
| 3241 | Qed. | ||
| 3243 | Lemma Inc_W3 w w3 w4 : IncN 3 w w3 -> shift w3 = Some w4 -> Inc (uW :: w) (uP :: w4). | ||
| 3244 | Proof. | ||
| 3245 | intros H Hs. destruct (IncN_3_inv _ _ H) as [a [b [H1 [H2 H3]]]]. | ||
| 3246 | eapply Inc_W; eauto. | ||
| 3247 | Qed. | ||
| 3249 | Lemma s1w_pos Q : 1 <= Q -> s1w Q = uP :: bin (2 * Q - 1). | ||
| 3250 | Proof. intros HQ. unfold s1w. destruct Q; [lia|reflexivity]. Qed. | ||
| 3252 | Definition gP (n Q : nat) : nat := (2 * Q + 1) * 2 ^ n - 8. | ||
| 3254 | Lemma HW n : 7 <= n -> 128 <= 2 ^ n. | ||
| 3255 | Proof. intros Hn. change 128 with (2 ^ 7). apply pow_ge. lia. Qed. | ||
| 3257 | Lemma Hg n Q : 7 <= n -> 8 * gP n Q + 64 = 8 * ((2 * Q + 1) * 2 ^ n). | ||
| 3258 | Proof. intros Hn. pose proof (HW n Hn). unfold gP. nia. Qed. | ||
| 3260 | Lemma vfl_S1 m V : 1 <= m -> vfl [[uS1]] m V = uS1 :: digits m V ++ uP :: bin (V / 2 ^ m). | ||
| 3261 | Proof. | ||
| 3262 | intros Hm. destruct m as [|m]; [lia|]. | ||
| 3263 | change (vfl [[uS1]] (S m) V) with (uS1 :: vfl [] (S m) V). f_equal. apply vfl_nil. | ||
| 3264 | Qed. | ||
| 3266 | Lemma digits_snoc' m x : 1 <= m -> x < 2 ^ (m - 1) -> digits m x = digits (m - 1) x ++ [uD0]. | ||
| 3267 | Proof. intros Hm Hx. destruct m as [|m]; [lia|]. replace (S m - 1) with m in * by lia. apply digits_snoc. exact Hx. Qed. | ||
| 3269 | Lemma P12 n Q : 7 <= n -> 1 <= Q -> | ||
| 3270 | CS ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q), 8 * gP n Q + 8, 8 * gP n Q + 12) | ||
| 3271 | ([uD0; uD0; uD0; uSP] ++ digits n (2 ^ n - 3) ++ bin (4 * Q + 1), 8 * gP n Q + 11, 8 * gP n Q + 13). | ||
| 3272 | Proof. | ||
| 3273 | intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *. | ||
| 3274 | assert (Hx : xfeed 4000 8 [uS1; uP; uP; uD0; uD0; uD0; uP] = | ||
| 3275 | Some (Ps 3 ++ [uD1; uD1; uD1; uP], 0%N)) by reflexivity. | ||
| 3276 | apply xfeed_sound in Hx. change (N.to_nat 8) with 8%nat in Hx. change (N.to_nat 0) with O in Hx. | ||
| 3277 | eapply (pstep _ _ 8 0 3 [uD1; uD1; uD1; uP] 7 3 0 ((2 * Q + 1) * W)); [exact Hx|reflexivity|reflexivity|reflexivity|reflexivity| | | | | |lia|lia]. | ||
| 3278 | - cbn. lia. | ||
| 3279 | - rewrite pjg. change (pj 12) with 48. change (2 ^ 3) with 8. lia. | ||
| 3280 | - rewrite pjg. change (pj 12) with 48. lia. | ||
| 3281 | - rewrite Nat.add_0_l. apply (IncN_dig_q n (W - 3) _ (2 * Q + 1) (W - 3)); [fold W; lia|fold W; nia|fold W; lia|]. | ||
| 3282 | replace (4 * Q + 1) with (2 * Q + (2 * Q + 1)) by lia. apply IncN_bin. | ||
| 3283 | - reflexivity. | ||
| 3284 | Qed. | ||
| 3286 | Lemma P13 n Q : 7 <= n -> 1 <= Q -> | ||
| 3287 | CS ([uD0; uD0; uD0; uSP] ++ digits n (2 ^ n - 3) ++ bin (4 * Q + 1), 8 * gP n Q + 11, 8 * gP n Q + 13) | ||
| 3288 | ([uD0; uS1; uD0; uP] ++ digits n (2 ^ n - 3) ++ uD0 :: s1w Q, 8 * gP n Q + 11, 8 * gP n Q + 14). | ||
| 3289 | Proof. | ||
| 3290 | intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *. | ||
| 3291 | set (R := digits n (W - 3) ++ bin (4 * Q + 1)). | ||
| 3292 | set (R4 := digits n 0 ++ digits 1 0 ++ uS1 :: bin Q). | ||
| 3293 | assert (HR : Inc (uW :: R) (uP :: R4)). | ||
| 3294 | { apply (Inc_W3 R (digits n 0 ++ bin (4 * Q + 2))). | ||
| 3295 | - unfold R. apply (IncN_dig_q n (W - 3) 3 1 0); [fold W; lia|fold W; lia|fold W; lia|]. | ||
| 3296 | replace (4 * Q + 2) with (4 * Q + 1 + 1) by lia. apply IncN_bin. | ||
| 3297 | - replace (4 * Q + 2) with (2 ^ 1 * (2 * Q + 1)) by (cbn; lia). rewrite bin_pow_odd, digits_0. | ||
| 3298 | rewrite shift_D0s. cbn [repeat app shift]. unfold R4. rewrite digits_0. reflexivity. } | ||
| 3299 | replace (8 * gP n Q + 14) with (S (8 * gP n Q + 13)) by lia. | ||
| 3300 | apply (cs_nodrop _ _ _ ([uD0; uD1; uD0; uP] ++ digits n (W - 3) ++ digits 1 0 ++ s1w Q)). | ||
| 3301 | - reflexivity. | ||
| 3302 | - rewrite pjg. change (pj 13) with 47. | ||
| 3303 | replace (8 * gP n Q + 11 + 47) with (8 + (8 + ((8 * ((2 * Q + 1) * W) - 22)))) by lia. | ||
| 3304 | eapply IncN_add. | ||
| 3305 | { change ([uD0; uD0; uD0; uSP] ++ R) with (digits 3 0 ++ uSP :: R). | ||
| 3306 | apply (IncN_dig_q 3 0 8 1 0 _ (uW :: R)); [cbn; lia|cbn; lia|cbn; lia|]. apply IncN_1. constructor. } | ||
| 3307 | eapply IncN_add. | ||
| 3308 | { apply (IncN_dig_q 3 0 8 1 0 _ (uP :: R4)); [cbn; lia|cbn; lia|cbn; lia|]. apply IncN_1. exact HR. } | ||
| 3309 | change ([uD0; uD1; uD0; uP] ++ digits n (W - 3) ++ digits 1 0 ++ s1w Q) | ||
| 3310 | with (digits 3 2 ++ uP :: digits n (W - 3) ++ digits 1 0 ++ s1w Q). | ||
| 3311 | apply (IncN_dig_q 3 0 _ ((2 * Q + 1) * W - 3) 2); [cbn; lia|change (2 ^ 3) with 8; nia|cbn; lia|]. | ||
| 3312 | apply IncN_P. unfold R4. | ||
| 3313 | apply (IncN_dig_q n 0 _ (2 * Q) (W - 3)); [fold W; lia|fold W; nia|fold W; lia|]. | ||
| 3314 | apply (IncN_dig_q 1 0 _ Q 0); [cbn; lia|cbn; lia|cbn; lia|]. apply IncN_s1w. | ||
| 3315 | - apply shiftX_app. reflexivity. | ||
| 3316 | Qed. | ||
| 3318 | Lemma P14 n Q : 7 <= n -> 1 <= Q -> | ||
| 3319 | CS ([uD0; uS1; uD0; uP] ++ digits n (2 ^ n - 3) ++ uD0 :: s1w Q, 8 * gP n Q + 11, 8 * gP n Q + 14) | ||
| 3320 | ([uS1; uP; uD0; uP] ++ digits n (2 ^ n - 5) ++ uD0 :: uP :: bin (4 * Q), 8 * gP n Q + 11, 8 * gP n Q + 15). | ||
| 3321 | Proof. | ||
| 3322 | intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *. | ||
| 3323 | assert (Hx : xfeed 4000 2 [uD0; uS1; uD0] = Some (Ps 0 ++ [uD0; uP; uD0], 0%N)) by reflexivity. | ||
| 3324 | apply xfeed_sound in Hx. change (N.to_nat 2) with 2%nat in Hx. change (N.to_nat 0) with O in Hx. | ||
| 3325 | change ([uD0; uS1; uD0; uP] ++ digits n (W - 3) ++ uD0 :: s1w Q) | ||
| 3326 | with ([uD0; uS1; uD0] ++ uP :: digits n (W - 3) ++ uD0 :: s1w Q). | ||
| 3327 | change ([uS1; uP; uD0; uP] ++ digits n (W - 5) ++ uD0 :: uP :: bin (4 * Q)) | ||
| 3328 | with ([uS1; uP; uD0] ++ uP :: digits n (W - 5) ++ uD0 :: uP :: bin (4 * Q)). | ||
| 3329 | eapply (pstep _ _ 2 0 0 [uD0; uP; uD0] 0 2 1 (2 * (2 * Q + 1) * W - 2)); [exact Hx|reflexivity|reflexivity|reflexivity|reflexivity| | | | | |lia|lia]. | ||
| 3330 | - cbn. lia. | ||
| 3331 | - rewrite pjg. change (pj 14) with 48. change (2 ^ 2) with 4. lia. | ||
| 3332 | - rewrite pjg. change (pj 14) with 48. lia. | ||
| 3333 | - rewrite Nat.add_0_l. apply IncN_P. rewrite s1w_pos by exact HQ. | ||
| 3334 | apply (IncN_dig_q n (W - 3) _ (2 * (2 * Q + 1)) (W - 5)); [fold W; lia|fold W; nia|fold W; lia|]. | ||
| 3335 | change (uD0 :: uP :: bin (2 * Q - 1)) with (digits 1 0 ++ uP :: bin (2 * Q - 1)). | ||
| 3336 | change (uD0 :: uP :: bin (4 * Q)) with (digits 1 0 ++ uP :: bin (4 * Q)). | ||
| 3337 | apply (IncN_dig_q 1 0 _ (2 * Q + 1) 0); [cbn; lia|cbn; lia|cbn; lia|]. | ||
| 3338 | apply IncN_P. replace (4 * Q) with (2 * Q - 1 + (2 * Q + 1)) by lia. apply IncN_bin. | ||
| 3339 | - reflexivity. | ||
| 3340 | Qed. | ||
| 3342 | Lemma P15 n Q : 7 <= n -> 1 <= Q -> | ||
| 3343 | CS ([uS1; uP; uD0; uP] ++ digits n (2 ^ n - 5) ++ uD0 :: uP :: bin (4 * Q), 8 * gP n Q + 11, 8 * gP n Q + 15) | ||
| 3344 | ([uS1; uP] ++ digits n (2 ^ n - 6) ++ uD0 :: uP :: bin (8 * Q + 2), 8 * gP n Q + 13, 8 * gP n Q + 16). | ||
| 3345 | Proof. | ||
| 3346 | intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *. | ||
| 3347 | assert (Hx : xfeed 4000 1 [uS1; uP; uD0] = Some (Ps 2 ++ [uD0], 0%N)) by reflexivity. | ||
| 3348 | apply xfeed_sound in Hx. change (N.to_nat 1) with 1%nat in Hx. change (N.to_nat 0) with O in Hx. | ||
| 3349 | change ([uS1; uP; uD0; uP] ++ digits n (W - 5) ++ uD0 :: uP :: bin (4 * Q)) | ||
| 3350 | with ([uS1; uP; uD0] ++ uP :: digits n (W - 5) ++ uD0 :: uP :: bin (4 * Q)). | ||
| 3351 | change ([uS1; uP] ++ digits n (W - 6) ++ uD0 :: uP :: bin (8 * Q + 2)) | ||
| 3352 | with ([uS1] ++ uP :: digits n (W - 6) ++ uD0 :: uP :: bin (8 * Q + 2)). | ||
| 3353 | eapply (pstep _ _ 1 0 2 [uD0] 0 1 1 (4 * (2 * Q + 1) * W - 1)); [exact Hx|reflexivity|reflexivity|reflexivity|reflexivity| | | | | |lia|lia]. | ||
| 3354 | - cbn. lia. | ||
| 3355 | - rewrite pjg. change (pj 15) with 47. change (2 ^ 1) with 2. lia. | ||
| 3356 | - rewrite pjg. change (pj 15) with 47. lia. | ||
| 3357 | - rewrite Nat.add_0_l. apply IncN_P. | ||
| 3358 | apply (IncN_dig_q n (W - 5) _ (4 * (2 * Q + 1)) (W - 6)); [fold W; lia|fold W; nia|fold W; lia|]. | ||
| 3359 | change (uD0 :: uP :: bin (4 * Q)) with (digits 1 0 ++ uP :: bin (4 * Q)). | ||
| 3360 | change (uD0 :: uP :: bin (8 * Q + 2)) with (digits 1 0 ++ uP :: bin (8 * Q + 2)). | ||
| 3361 | apply (IncN_dig_q 1 0 _ (2 * (2 * Q + 1)) 0); [cbn; lia|cbn; lia|cbn; lia|]. | ||
| 3362 | apply IncN_P. replace (8 * Q + 2) with (4 * Q + 2 * (2 * Q + 1)) by lia. apply IncN_bin. | ||
| 3363 | - reflexivity. | ||
| 3364 | Qed. | ||
| 3366 | Lemma P16 n Q : 7 <= n -> 1 <= Q -> | ||
| 3367 | CS ([uS1; uP] ++ digits n (2 ^ n - 6) ++ uD0 :: uP :: bin (8 * Q + 2), 8 * gP n Q + 13, 8 * gP n Q + 16) | ||
| 3368 | ([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17). | ||
| 3369 | Proof. | ||
| 3370 | intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *. | ||
| 3371 | set (H := 2 ^ (n - 1)). | ||
| 3372 | assert (EH : W = 2 * H) by (unfold W, H; replace n with (S (n - 1)) at 1 by lia; apply Nat.pow_succ_r'). | ||
| 3373 | assert (Ed : digits n (W - 6) = uD0 :: digits (n - 1) (H - 3)). | ||
| 3374 | { replace n with (S (n - 1)) at 1 by lia. change (digits (S (n - 1)) (W - 6)) with (dig (W - 6) :: digits (n - 1) ((W - 6) / 2)). | ||
| 3375 | replace (W - 6) with (2 * (H - 3)) by lia. rewrite dig_even. | ||
| 3376 | rewrite (Nat.mul_comm 2 (H - 3)), Nat.div_mul by lia. reflexivity. } | ||
| 3377 | rewrite Ed. | ||
| 3378 | assert (Hx : xfeed 4000 1 [uS1; uP; uD0] = Some (Ps 2 ++ [uD0], 0%N)) by reflexivity. | ||
| 3379 | apply xfeed_sound in Hx. change (N.to_nat 1) with 1%nat in Hx. change (N.to_nat 0) with O in Hx. | ||
| 3380 | change ([uS1; uP] ++ (uD0 :: digits (n - 1) (H - 3)) ++ uD0 :: uP :: bin (8 * Q + 2)) | ||
| 3381 | with ([uS1; uP; uD0] ++ digits (n - 1) (H - 3) ++ uD0 :: uP :: bin (8 * Q + 2)). | ||
| 3382 | eapply (pstep _ _ 1 0 2 [uD0] 0 1 1 (4 * (2 * Q + 1) * W)); [exact Hx|reflexivity|reflexivity|reflexivity|reflexivity| | | | | |lia|lia]. | ||
| 3383 | - cbn. lia. | ||
| 3384 | - rewrite pjg. change (pj 16) with 47. change (2 ^ 1) with 2. lia. | ||
| 3385 | - rewrite pjg. change (pj 16) with 47. lia. | ||
| 3386 | - rewrite Nat.add_0_l. | ||
| 3387 | assert (HH : 64 <= H) by lia. | ||
| 3388 | apply (IncN_dig_q (n - 1) (H - 3) _ (8 * (2 * Q + 1)) (H - 3)); [fold H; lia|fold H; nia|fold H; lia|]. | ||
| 3389 | change (uD0 :: uP :: bin (8 * Q + 2)) with (digits 1 0 ++ uP :: bin (8 * Q + 2)). | ||
| 3390 | change (uD0 :: uP :: bin (16 * Q + 6)) with (digits 1 0 ++ uP :: bin (16 * Q + 6)). | ||
| 3391 | apply (IncN_dig_q 1 0 _ (4 * (2 * Q + 1)) 0); [cbn; lia|cbn; lia|cbn; lia|]. | ||
| 3392 | apply IncN_P. replace (16 * Q + 6) with (8 * Q + 2 + 4 * (2 * Q + 1)) by lia. apply IncN_bin. | ||
| 3393 | - reflexivity. | ||
| 3394 | Qed. | ||
| 3396 | Theorem LemmaP n Q : 7 <= n -> 1 <= Q -> | ||
| 3397 | CSplus ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q), 8 * gP n Q + 8, 8 * gP n Q + 12) | ||
| 3398 | ([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17). | ||
| 3399 | Proof. | ||
| 3400 | intros Hn HQ. | ||
| 3401 | eapply CSpS; [apply P12; auto|]. eapply CSpS; [apply P13; auto|]. eapply CSpS; [apply P14; auto|]. | ||
| 3402 | eapply CSpS; [apply P15; auto|]. apply CSp1. apply P16; auto. | ||
| 3403 | Qed. | ||
| 3405 | (* the plant end is the level-2 value form at off' 17 *) | ||
| 3406 | Lemma P_id n Q : 7 <= n -> 1 <= Q -> | ||
| 3407 | ([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17) | ||
| 3408 | = vfz (phrow 1) (n - 7) ((2 * Q + 1) * 2 ^ (n + 3)) 17. | ||
| 3409 | Proof. | ||
| 3410 | intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. | ||
| 3411 | assert (EH : 2 ^ n = 2 * 2 ^ (n - 1)) by (replace n with (S (n - 1)) at 1 by lia; apply Nat.pow_succ_r'). | ||
| 3412 | assert (E3 : 2 ^ (n + 3) = 8 * 2 ^ n) by (rewrite Nat.pow_add_r; change (2 ^ 3) with 8; lia). | ||
| 3413 | assert (HH : 64 <= 2 ^ (n - 1)) by lia. | ||
| 3414 | unfold vfz. change (phrow 1) with (mkV [[uS1]] 24 1 1 0 20 2). cbn [vlam vmu val_ vwp vwn vd vh]. | ||
| 3415 | replace (n - 7 + 24 - 17) with n by lia. | ||
| 3416 | match goal with |- context [vfl _ _ ?V] => | ||
| 3417 | replace V with ((2 ^ (n - 1) - 3) + 2 ^ n * (16 * Q + 6)) by (rewrite E3, EH; rewrite EH in Hg'; nia) end. | ||
| 3418 | rewrite vfl_S1 by lia. rewrite digits_mod. rewrite (digits_snoc' n) by lia. | ||
| 3419 | replace ((2 ^ (n - 1) - 3 + 2 ^ n * (16 * Q + 6)) / 2 ^ n) with (16 * Q + 6) | ||
| 3420 | by (apply Nat.div_unique with (2 ^ (n - 1) - 3); lia). | ||
| 3421 | f_equal; [f_equal|]; try (cbn [app]; rewrite <- ?app_assoc; reflexivity); rewrite E3; lia. | ||
| 3422 | Qed. | ||
| 3424 | (* the start of the plant is the value form at off_end(K) when 8 | K + 9 *) | ||
| 3425 | Lemma vfl_plant y : vfl [[uS1; uP; uP]] 3 (8 * y) = [uS1; uP; uP; uD0; uD0; uD0; uP] ++ bin y. | ||
| 3426 | Proof. | ||
| 3427 | cbn [vfl hd tl app]. | ||
| 3428 | replace (8 * y) with (2 * (4 * y)) by lia. rewrite dig_even. | ||
| 3429 | rewrite (Nat.mul_comm 2 (4 * y)), Nat.div_mul by lia. | ||
| 3430 | replace (4 * y) with (2 * (2 * y)) by lia. rewrite dig_even. | ||
| 3431 | rewrite (Nat.mul_comm 2 (2 * y)), Nat.div_mul by lia. rewrite dig_even. | ||
| 3432 | rewrite (Nat.mul_comm 2 y), Nat.div_mul by lia. reflexivity. | ||
| 3433 | Qed. | ||
| 3437 | Lemma VFe_plant K Om n Q : 7 <= n -> 1 <= Q -> (K + 9) mod 8 = O -> 41 <= K -> | ||
| 3438 | Om + K + 9 = (2 * Q + 1) * 2 ^ (n + 3) -> | ||
| 3439 | VFe K Om = ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q), | ||
| 3440 | 8 * gP n Q + 8, 8 * gP n Q + 12). | ||
| 3441 | Proof. | ||
| 3442 | intros Hn HQ H8 HK HM. | ||
| 3443 | assert (HW : 128 <= 2 ^ n) by (change 128 with (2 ^ 7); apply pow_ge; lia). | ||
| 3444 | assert (E3 : 2 ^ (n + 3) = 8 * 2 ^ n) by (rewrite Nat.pow_add_r; change (2 ^ 3) with 8; lia). | ||
| 3445 | assert (Eo : off_end K = K + 21). | ||
| 3446 | { unfold off_end. replace ((K + 20) mod 8) with 3; [reflexivity|]. | ||
| 3447 | replace (K + 20) with (3 + ((K + 9) / 8 + 1) * 8) by (pose proof (Nat.div_mod_eq (K + 9) 8); lia). | ||
| 3448 | rewrite Nat.Div0.mod_add. reflexivity. } | ||
| 3449 | assert (E4 : (K + 21) mod 8 = 4). | ||
| 3450 | { replace (K + 21) with (4 + ((K + 9) / 8 + 1) * 8) by (pose proof (Nat.div_mod_eq (K + 9) 8); lia). | ||
| 3451 | rewrite Nat.Div0.mod_add. reflexivity. } | ||
| 3452 | unfold VFe. rewrite Eo, E4. unfold vfz. change (phrow 4) with (mkV [[uS1; uP; uP]] 24 1 1 0 24 4). | ||
| 3453 | cbn [vlam vmu val_ vwp vwn vd vh]. | ||
| 3454 | replace (K + 24 - (K + 21)) with 3 by lia. | ||
| 3455 | change (2 ^ (3 - 1)) with 4. | ||
| 3456 | match goal with |- context [vfl _ _ ?V] => | ||
| 3457 | replace V with (8 * ((2 ^ n - 3) + 2 ^ n * (2 * Q))) by (rewrite E3 in HM; clear -HM HW; nia) end. | ||
| 3458 | rewrite vfl_plant. rewrite <- digits_app_bin by lia. | ||
| 3459 | unfold gP. f_equal; [f_equal|]; nia. | ||
| 3460 | Qed. | ||
| 3462 | (* ===================================================================== *) | ||
| 3463 | (* 25. The class recursion E(K) and Theorem B (proof.md 6.5, 6.7). *) | ||
| 3464 | (* ===================================================================== *) | ||
| 3466 | Theorem EK K : 41 <= K -> forall U, 1 <= U -> exists b', CSplus (VFe K (U * 2 ^ (K + 5))) (Cst b'). | ||
| 3467 | Proof. | ||
| 3468 | induction K as [K IH] using lt_wf_ind. intros HK U HU. | ||
| 3469 | destruct (odd_decomp (K + 9) ltac:(lia)) as [v [s [Hks Hs]]]. | ||
| 3470 | destruct (Nat.le_gt_cases v 50) as [Hv|Hv]. | ||
| 3471 | - eapply E_low; eauto. | ||
| 3472 | - (* the plant, Lemma VF at level 2, then the induction hypothesis at v - 10 *) | ||
| 3473 | assert (Hs1 : 1 <= s) by (destruct s; [discriminate|lia]). | ||
| 3474 | assert (Hlin : v + 5 <= 2 ^ v). | ||
| 3475 | { assert (v - 1 < 2 ^ (v - 1)) by (apply Nat.pow_gt_lin_r; lia). | ||
| 3476 | replace v with (S (v - 1)) at 2 by lia. rewrite Nat.pow_succ_r'. lia. } | ||
| 3477 | assert (Hpk : 2 ^ v <= K + 9) by (rewrite Hks; clear -Hs1; nia). | ||
| 3478 | assert (Hvk : v + 1 <= K + 5) by lia. | ||
| 3479 | set (S0 := s + U * 2 ^ (K + 5 - v)). | ||
| 3480 | assert (ES : U * 2 ^ (K + 5) + K + 9 = S0 * 2 ^ v). | ||
| 3481 | { unfold S0. replace (U * 2 ^ (K + 5) + K + 9) with (U * 2 ^ (K + 5) + (K + 9)) by lia. | ||
| 3482 | rewrite Hks. replace (K + 5) with ((K + 5 - v) + v) at 1 by lia. | ||
| 3483 | rewrite Nat.pow_add_r. nia. } | ||
| 3484 | assert (Hodd : Nat.odd S0 = true). | ||
| 3485 | { unfold S0. replace (K + 5 - v) with (S (K + 4 - v)) by lia. rewrite Nat.pow_succ_r'. | ||
| 3486 | rewrite Nat.odd_add, Hs. | ||
| 3487 | replace (U * (2 * 2 ^ (K + 4 - v))) with (2 * (U * 2 ^ (K + 4 - v))) by lia. | ||
| 3488 | rewrite Nat.odd_mul. reflexivity. } | ||
| 3489 | destruct (proj1 (Nat.odd_spec S0) Hodd) as [Q EQ]. | ||
| 3490 | assert (HQ : 1 <= Q). | ||
| 3491 | { assert (2 <= U * 2 ^ (K + 5 - v)). | ||
| 3492 | { replace (K + 5 - v) with (S (K + 4 - v)) by lia. rewrite Nat.pow_succ_r'. | ||
| 3493 | pose proof (Nat.pow_nonzero 2 (K + 4 - v)). nia. } | ||
| 3494 | unfold S0 in EQ. lia. } | ||
| 3495 | set (n := v - 3). | ||
| 3496 | assert (Hn : 7 <= n) by (unfold n; lia). | ||
| 3497 | assert (Ev : n + 3 = v) by (unfold n; lia). | ||
| 3498 | assert (H8 : (K + 9) mod 8 = O). | ||
| 3499 | { rewrite Hks. replace v with (3 + (v - 3)) by lia. rewrite Nat.pow_add_r. | ||
| 3500 | replace (s * (2 ^ 3 * 2 ^ (v - 3))) with ((s * 2 ^ (v - 3)) * 8) by (change (2 ^ 3) with 8; lia). | ||
| 3501 | apply Nat.Div0.mod_mul. } | ||
| 3502 | destruct (IH (v - 10) ltac:(lia) ltac:(lia) (32 * S0) ltac:(lia)) as [b' Hb']. exists b'. | ||
| 3503 | rewrite (VFe_plant K (U * 2 ^ (K + 5)) n Q Hn HQ H8 HK) by (rewrite Ev, ES, EQ; lia). | ||
| 3504 | eapply CSplus_trans; [apply (LemmaP n Q Hn HQ)|]. | ||
| 3505 | rewrite (P_id n Q Hn HQ). | ||
| 3506 | replace (n - 7) with (v - 10) by lia. rewrite Ev. | ||
| 3507 | replace (2 * Q + 1) with S0 by lia. | ||
| 3508 | eapply CSstar_plus; [apply VF2; lia|]. | ||
| 3509 | replace (S0 * 2 ^ v) with ((32 * S0) * 2 ^ (v - 10 + 5)). | ||
| 3510 | + exact Hb'. | ||
| 3511 | + assert (E5 : 2 ^ v = 32 * 2 ^ (v - 10 + 5)). | ||
| 3512 | { replace v with (5 + (v - 10 + 5)) at 1 by lia. rewrite Nat.pow_add_r. change (2 ^ 5) with 32. lia. } | ||
| 3513 | rewrite E5. ring. | ||
| 3514 | Qed. | ||
| 3516 | Theorem thmB b : exists b', CSplus (Cst b) (Cst b'). | ||
| 3517 | Proof. | ||
| 3518 | destruct (odd_decomp (b + 2) ltac:(lia)) as [k [o [Hb Ho]]]. | ||
| 3519 | destruct (Nat.le_gt_cases k 40) as [Hk|Hk]. | ||
| 3520 | - eapply small_classes; eauto. | ||
| 3521 | - destruct (proj1 (Nat.odd_spec o) Ho) as [q Eq]. | ||
| 3522 | replace b with ((2 * q + 1) * 2 ^ k - 2) by lia. | ||
| 3523 | destruct (EK k ltac:(lia) (2 * q + 1) ltac:(lia)) as [b' Hb']. exists b'. | ||
| 3524 | eapply CSplus_trans; [apply LemmaE; lia|]. | ||
| 3525 | eapply CSstar_plus; [apply VF1; lia|]. | ||
| 3526 | exact Hb'. | ||
| 3527 | Qed. | ||
| 3529 | (* ===================================================================== *) | ||
| 3530 | (* 26. The closed system runs forever: every step j >= 1 is reached. *) | ||
| 3531 | (* ===================================================================== *) | ||
| 3533 | Definition CSr (s : st) : Prop := CSreach (fst (fst s)) (snd (fst s)) (snd s). | ||
| 3535 | Lemma CSplus_reach s s' : CSr s -> CSplus s s' -> CSr s'. | ||
| 3536 | Proof. | ||
| 3537 | intros H1 H2. induction H2 as [x y Hs|x y z Hs H IH]. | ||
| 3538 | - destruct x as [[zx dx] jx], y as [[zy dy] jy]. unfold CSr in *. cbn in *. econstructor; eauto. | ||
| 3539 | - apply IH. destruct x as [[zx dx] jx], y as [[zy dy] jy]. unfold CSr in *. cbn in *. econstructor; eauto. | ||
| 3540 | Qed. | ||
| 3542 | Lemma all_Cst N0 : exists b, N0 <= b /\ CSr (Cst b). | ||
| 3543 | Proof. | ||
| 3544 | induction N0 as [|N0 [b [Hb HR]]]. | ||
| 3545 | - exists O. split; [lia|]. exact C0_reach. | ||
| 3546 | - destruct (thmB b) as [b' Hp]. exists b'. split. | ||
| 3547 | + pose proof (CSplus_j _ _ Hp) as Hj. cbn in Hj. lia. | ||
| 3548 | + eapply CSplus_reach; eauto. | ||
| 3549 | Qed. | ||
| 3551 | Lemma CSreach_down Z D j : CSreach Z D j -> forall j', 1 <= j' <= j -> exists Z' D', CSreach Z' D' j'. | ||
| 3552 | Proof. | ||
| 3553 | induction 1 as [|Z D j Z' D' j' H IH Hs]; intros j0 Hj0. | ||
| 3554 | - assert (j0 = 1%nat) by lia. subst. eexists _, _. constructor. | ||
| 3555 | - assert (Ej : j' = S j) by (destruct Hs as [m [A [Y [_ [_ [_ [_ [_ [_ Ej]]]]]]]]]; exact Ej). | ||
| 3556 | destruct (Nat.eq_dec j0 j') as [->|Hne]. | ||
| 3557 | + exists Z', D'. econstructor; eauto. | ||
| 3558 | + apply IH. lia. | ||
| 3559 | Qed. | ||
| 3561 | Theorem zone_forever J : 1 <= J -> exists Z D, CSreach Z D J. | ||
| 3562 | Proof. | ||
| 3563 | intros HJ. destruct (all_Cst J) as [b [Hb HR]]. | ||
| 3564 | unfold CSr, Cst in HR. cbn in HR. | ||
| 3565 | eapply CSreach_down; [exact HR|lia]. | ||
| 3566 | Qed. | ||
| 3569 | (* ===================================================================== *) | ||
| 3570 | (* 27. The closed-system orbit is a function: determinism, and every *) | ||
| 3571 | (* reached state has a next step. *) | ||
| 3572 | (* ===================================================================== *) | ||
| 3574 | Lemma cs_step_j Z D j Z' D' j' : cs_step Z D j Z' D' j' -> j' = S j. | ||
| 3575 | Proof. intros [m [a [y [_ [_ [_ [_ [_ [_ E]]]]]]]]]. exact E. Qed. | ||
| 3577 | Lemma cs_step_det Z D j Z1 D1 j1 Z2 D2 j2 : | ||
| 3578 | cs_step Z D j Z1 D1 j1 -> cs_step Z D j Z2 D2 j2 -> Z1 = Z2 /\ D1 = D2. | ||
| 3579 | Proof. | ||
| 3580 | intros Hc1 Hc2. | ||
| 3581 | destruct Hc1 as [m1 [a1 [y1 [H1 [N1 [E1 [M1 [Hs1 [Ed1 _]]]]]]]]]. | ||
| 3582 | destruct Hc2 as [m2 [a2 [y2 [H2 [N2 [E2 [M2 [Hs2 [Ed2 _]]]]]]]]]. | ||
| 3583 | assert (Em : m1 = m2). | ||
| 3584 | { destruct (Nat.lt_trichotomy m1 m2) as [Hl|[Hl|Hl]]; auto. | ||
| 3585 | - exfalso. exact (M2 m1 a1 y1 Hl H1 N1 E1). | ||
| 3586 | - exfalso. exact (M1 m2 a2 y2 Hl H2 N2 E2). } | ||
| 3587 | rewrite <- Em in H2. pose proof (IncN_det _ _ _ _ H1 H2) as E. | ||
| 3588 | destruct (Ps_notP_inj _ _ _ _ E N1 N2) as [Ea Ey]. subst a2 y2. | ||
| 3589 | rewrite Hs1 in Hs2. injection Hs2 as Hz. split; [exact Hz|lia]. | ||
| 3590 | Qed. | ||
| 3592 | Lemma CSreach_pos Z D j : CSreach Z D j -> 1 <= j. | ||
| 3593 | Proof. induction 1 as [|Z D j Z' D' j' H IH Hs]; [lia|]. apply cs_step_j in Hs. lia. Qed. | ||
| 3595 | Lemma CSreach_det Z1 D1 j : CSreach Z1 D1 j -> forall Z2 D2, CSreach Z2 D2 j -> Z1 = Z2 /\ D1 = D2. | ||
| 3596 | Proof. | ||
| 3597 | induction 1 as [|Z D j Z' D' j' H IH Hs]; intros Z2 D2 H2. | ||
| 3598 | - inversion H2 as [|z0 d0 k0 z1 d1 k1 H0 Hs0]; subst; [auto|]. | ||
| 3599 | apply cs_step_j in Hs0. apply CSreach_pos in H0. lia. | ||
| 3600 | - pose proof (cs_step_j _ _ _ _ _ _ Hs) as Ej. subst j'. | ||
| 3601 | inversion H2 as [|z0 d0 k0 z1 d1 k1 H0 Hs0]; subst. | ||
| 3602 | + apply CSreach_pos in H. lia. | ||
| 3603 | + pose proof (cs_step_j _ _ _ _ _ _ Hs0) as Ej0. assert (k0 = j) by lia. subst k0. | ||
| 3604 | destruct (IH _ _ H0) as [Ez Ed]. subst z0 d0. | ||
| 3605 | exact (cs_step_det _ _ _ _ _ _ _ _ _ Hs Hs0). | ||
| 3606 | Qed. | ||
| 3608 | (* every reached state of the closed system has its next step *) | ||
| 3609 | Theorem CS_next Z D j : CSreach Z D j -> exists Z' D', cs_step Z D j Z' D' (S j). | ||
| 3610 | Proof. | ||
| 3611 | intros H. destruct (zone_forever (S j) ltac:(lia)) as [Z2 [D2 H2]]. | ||
| 3612 | inversion H2 as [|z0 d0 k0 z1 d1 k1 H0 Hs0]; subst. | ||
| 3613 | - apply CSreach_pos in H. lia. | ||
| 3614 | - pose proof (cs_step_j _ _ _ _ _ _ Hs0) as E. assert (k0 = j) by lia. subst k0. | ||
| 3615 | destruct (CSreach_det _ _ _ H0 _ _ H) as [Ez Ed]. subst z0 d0. eauto. | ||
| 3616 | Qed. | ||
| 3618 | (* below the least fixed point the zone count stays under c + 3 A(m) *) | ||
| 3619 | Lemma leading_P w : exists a y, w = Ps a ++ y /\ notP y. | ||
| 3620 | Proof. | ||
| 3621 | induction w as [|u w [a [y [E N]]]]. | ||
| 3622 | - exists O, (@nil unt). split; [reflexivity|exact I]. | ||
| 3623 | - destruct u; [exists O, (uD0 :: w) | exists O, (uD1 :: w) | exists (S a), y | ||
| 3624 | | exists O, (uS1 :: w) | exists O, (uSP :: w) | exists O, (uW :: w)]; | ||
| 3625 | (split; [cbn; try (subst w); reflexivity | cbn; try exact I; exact N]). | ||
| 3626 | Qed. | ||
| 3628 | Lemma IncN_le m m' Z Y : m' <= m -> IncN m Z Y -> exists Y', IncN m' Z Y'. | ||
| 3629 | Proof. | ||
| 3630 | intros Hle H. replace m with (m' + (m - m')) in H by lia. | ||
| 3631 | destruct (IncN_split _ _ _ _ H) as [Y1 [H1 _]]. eauto. | ||
| 3632 | Qed. | ||
| 3634 | (* ===================================================================== *) | ||
| 3635 | (* 28. Pops through a conveyor wall that is not the top wall: a wall *) | ||
| 3636 | (* fed by f pops fires (3 f + b) / 2 times, each a pop of the rest. *) | ||
| 3637 | (* ===================================================================== *) | ||
| 3639 | Lemma odd_plus2 n : Nat.odd (n + 2) = Nat.odd n. | ||
| 3640 | Proof. replace (n + 2) with (S (S n)) by lia. apply Nat.odd_succ_succ. Qed. | ||
| 3642 | Lemma Ps_add a b x : Ps a ++ Ps b ++ x = Ps (a + b) ++ x. | ||
| 3643 | Proof. induction a as [|a IH]; [reflexivity|]. cbn [Ps app]. rewrite IH. reflexivity. Qed. | ||
| 3645 | Lemma Pops_wall f a (b : bool) r r' : | ||
| 3646 | Pops ((3 * f + Nat.b2n b) / 2) r r' -> | ||
| 3647 | Pops f (Ps a ++ wallu b :: r) | ||
| 3648 | (Ps (a + (3 * f + Nat.b2n b) / 2 - f) ++ wallu (Nat.odd (3 * f + Nat.b2n b)) :: r'). | ||
| 3649 | Proof. | ||
| 3650 | revert a b r. induction f as [|f IH]; intros a b r H. | ||
| 3651 | - destruct b; simpl in H |- *; subst r'; rewrite ?Nat.add_0_r, ?Nat.sub_0_r; reflexivity. | ||
| 3652 | - set (g := (3 + Nat.b2n b) / 2). | ||
| 3653 | set (b1 := Nat.odd (3 + Nat.b2n b)). | ||
| 3654 | assert (Eg : (3 * S f + Nat.b2n b) / 2 = g + (3 * f + Nat.b2n b1) / 2). | ||
| 3655 | { unfold g, b1. destruct b. | ||
| 3656 | - change (Nat.b2n true) with 1%nat. change (Nat.odd (3 + 1)) with false. change (Nat.b2n false) with O. | ||
| 3657 | replace (3 * S f + 1) with ((3 * f + 0) + 2 * 2) by lia. | ||
| 3658 | rewrite Nat.div_add by lia. change ((3 + 1) / 2) with 2%nat. lia. | ||
| 3659 | - change (Nat.b2n false) with O. change (Nat.odd (3 + 0)) with true. change (Nat.b2n true) with 1%nat. | ||
| 3660 | replace (3 * S f + 0) with ((3 * f + 1) + 1 * 2) by lia. | ||
| 3661 | rewrite Nat.div_add by lia. change ((3 + 0) / 2) with 1%nat. lia. } | ||
| 3662 | assert (Eo : Nat.odd (3 * S f + Nat.b2n b) = Nat.odd (3 * f + Nat.b2n b1)). | ||
| 3663 | { unfold b1. destruct b. | ||
| 3664 | - change (Nat.b2n true) with 1%nat. change (Nat.odd (3 + 1)) with false. change (Nat.b2n false) with O. | ||
| 3665 | replace (3 * S f + 1) with ((3 * f + 0) + 2 + 2) by lia. rewrite !odd_plus2. reflexivity. | ||
| 3666 | - change (Nat.b2n false) with O. change (Nat.odd (3 + 0)) with true. change (Nat.b2n true) with 1%nat. | ||
| 3667 | replace (3 * S f + 0) with ((3 * f + 1) + 2) by lia. rewrite odd_plus2. reflexivity. } | ||
| 3668 | rewrite Eg in H. destruct (Pops_split _ _ _ _ H) as [r1 [H1 H2]]. | ||
| 3669 | assert (Hg : 1 <= g) by (unfold g; destruct b; cbn; lia). | ||
| 3670 | exists (Ps (a + g - 1) ++ wallu b1 :: r1). split. | ||
| 3671 | + apply Inc3Pop_of. | ||
| 3672 | replace (uP :: Ps (a + g - 1) ++ wallu b1 :: r1) with (Ps a ++ Ps g ++ wallu b1 :: r1). | ||
| 3673 | * apply IncN_Ps. apply (wall_feed 3 b r r1 H1). | ||
| 3674 | * rewrite Ps_add. assert (Ea : a + g = S (a + g - 1)) by lia. rewrite Ea at 1. reflexivity. | ||
| 3675 | + rewrite Eo, Eg. replace (a + (g + (3 * f + Nat.b2n b1) / 2) - S f) | ||
| 3676 | with (a + g - 1 + (3 * f + Nat.b2n b1) / 2 - f) by lia. | ||
| 3677 | apply IH. exact H2. | ||
| 3678 | Qed. | ||
| 3680 | (* ===================================================================== *) | ||
| 3681 | (* 29. Birth data of the walls (proof.md 4, 5) and the bracket of Lemma T. *) | ||
| 3682 | (* Wall w < 6 is a wall of U0 (absorption order); wall w >= 6 has *) | ||
| 3683 | (* birth phase (w - 6) mod 8. b is the birth index in the U0 frame, *) | ||
| 3684 | (* s = 1 for W, H the carries received before the next wall's birth. *) | ||
| 3685 | (* ===================================================================== *) | ||
| 3687 | Definition u0b : list Z := [32; 20; 12; 7; 3; 1]%Z. | ||
| 3688 | Definition u0s : list nat := [1; 1; 1; 0; 1; 0]%nat. | ||
| 3689 | Definition u0H : list nat := [0; 0; 0; 0; 0; 9]%nat. | ||
| 3690 | Definition phb : list Z := [2; 0; -1; 10; 5; 2; 0; 1]%Z. | ||
| 3691 | Definition phs : list nat := [0; 1; 1; 0; 0; 1; 1; 0]%nat. | ||
| 3692 | Definition phH : list nat := [0; 0; 36; 0; 0; 0; 6; 9]%nat. | ||
| 3694 | Definition wb (w : nat) : Z := if Nat.ltb w 6 then nth w u0b 0%Z else nth ((w - 6) mod 8) phb 0%Z. | ||
| 3695 | Definition wsb (w : nat) : nat := if Nat.ltb w 6 then nth w u0s O else nth ((w - 6) mod 8) phs O. | ||
| 3696 | Definition wH (w : nat) : nat := if Nat.ltb w 6 then nth w u0H O else nth ((w - 6) mod 8) phH O. | ||
| 3698 | (* Lemma T: p(J mod 8) = 43 - 3 b_J + 2 b_(J-1) + s_(J-1) + H_(J-1) *) | ||
| 3699 | Definition bracket_ok (J : nat) : bool := | ||
| 3700 | Z.eqb (Z.of_nat (pj J)) | ||
| 3701 | (43 - 3 * wb J + 2 * wb (J - 1) + Z.of_nat (wsb (J - 1)) + Z.of_nat (wH (J - 1)))%Z. | ||
| 3703 | Lemma bracket_small : forallb bracket_ok [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14]%nat = true. | ||
| 3704 | Proof. vm_compute. reflexivity. Qed. | ||
| 3706 | Lemma wdata_period w : 6 <= w -> wb (w + 8) = wb w /\ wsb (w + 8) = wsb w /\ wH (w + 8) = wH w. | ||
| 3707 | Proof. | ||
| 3708 | intros Hw. unfold wb, wsb, wH. | ||
| 3709 | destruct (Nat.ltb_spec (w + 8) 6) as [|_]; [lia|]. destruct (Nat.ltb_spec w 6) as [|_]; [lia|]. | ||
| 3710 | replace (w + 8 - 6) with ((w - 6) + 1 * 8) by lia. rewrite Nat.Div0.mod_add. auto. | ||
| 3711 | Qed. | ||
| 3713 | Theorem bracket J : 1 <= J -> bracket_ok J = true. | ||
| 3714 | Proof. | ||
| 3715 | induction J as [J IH] using lt_wf_ind. intros HJ. | ||
| 3716 | destruct (Nat.le_gt_cases J 14) as [Hle|Hgt]. | ||
| 3717 | - pose proof bracket_small as H. rewrite forallb_forall in H. apply H. | ||
| 3718 | cbn [In]. lia. | ||
| 3719 | - specialize (IH (J - 8) ltac:(lia) ltac:(lia)). | ||
| 3720 | unfold bracket_ok in *. | ||
| 3721 | destruct (wdata_period (J - 8) ltac:(lia)) as [E1 [_ _]]. | ||
| 3722 | destruct (wdata_period (J - 1 - 8) ltac:(lia)) as [F1 [F2 F3]]. | ||
| 3723 | replace (J - 8 + 8) with J in E1 by lia. replace (J - 1 - 8 + 8) with (J - 1) in F1, F2, F3 by lia. | ||
| 3724 | replace (J - 8 - 1) with (J - 1 - 8) in IH by lia. | ||
| 3725 | rewrite E1, F1, F2, F3. | ||
| 3726 | replace (pj J) with (pj (J - 8)); [exact IH|]. | ||
| 3727 | assert (EJ : J mod 8 = (J - 8) mod 8). | ||
| 3728 | { rewrite <- (Nat.Div0.mod_add (J - 8) 1 8). f_equal. lia. } | ||
| 3729 | rewrite (pj_mod J), (pj_mod (J - 8)), EJ. reflexivity. | ||
| 3730 | Qed. | ||
| 3733 | (* ===================================================================== *) | ||
| 3734 | (* 30. The conveyor seen from a position: walls with absolute positions *) | ||
| 3735 | (* and carry counts, and above the youngest absorbed wall the zone *) | ||
| 3736 | (* of the next interval. Positions are in the U0 frame shifted by *) | ||
| 3737 | (* one, so the zone bottom is 44 + D + A. *) | ||
| 3738 | (* ===================================================================== *) | ||
| 3740 | Lemma wb_ge w : (-1 <= wb w)%Z. | ||
| 3741 | Proof. | ||
| 3742 | unfold wb. destruct (Nat.ltb w 6). | ||
| 3743 | - assert (H : forall i, (-1 <= nth i u0b 0)%Z). | ||
| 3744 | { intros i. do 6 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. } | ||
| 3745 | apply H. | ||
| 3746 | - assert (H : forall i, (-1 <= nth i phb 0)%Z). | ||
| 3747 | { intros i. do 8 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. } | ||
| 3748 | apply H. | ||
| 3749 | Qed. | ||
| 3751 | Lemma wb_le w : (wb w <= 32)%Z. | ||
| 3752 | Proof. | ||
| 3753 | unfold wb. destruct (Nat.ltb w 6). | ||
| 3754 | - assert (H : forall i, (nth i u0b 0 <= 32)%Z). | ||
| 3755 | { intros i. do 6 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. } | ||
| 3756 | apply H. | ||
| 3757 | - assert (H : forall i, (nth i phb 0 <= 32)%Z). | ||
| 3758 | { intros i. do 8 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. } | ||
| 3759 | apply H. | ||
| 3760 | Qed. | ||
| 3762 | Lemma wsb_le w : wsb w <= 1. | ||
| 3763 | Proof. | ||
| 3764 | unfold wsb. destruct (Nat.ltb w 6). | ||
| 3765 | - assert (H : forall i, nth i u0s O <= 1). | ||
| 3766 | { intros i. do 6 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. } | ||
| 3767 | apply H. | ||
| 3768 | - assert (H : forall i, nth i phs O <= 1). | ||
| 3769 | { intros i. do 8 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. } | ||
| 3770 | apply H. | ||
| 3771 | Qed. | ||
| 3773 | Definition bq (w : nat) : nat := Z.to_nat (wb w + 1). | ||
| 3774 | Definition fw (w R : nat) : nat := (R + wsb w) / 2. | ||
| 3775 | Definition posw (w R : nat) : nat := bq w + fw w R. | ||
| 3776 | Definition Rab (w D : nat) : nat := 2 * (44 + D - bq w) - wsb w. | ||
| 3778 | Lemma bq_spec w : Z.of_nat (bq w) = (wb w + 1)%Z. | ||
| 3779 | Proof. unfold bq. pose proof (wb_ge w). rewrite Z2Nat.id; lia. Qed. | ||
| 3781 | Lemma bq_le w : bq w <= 33. | ||
| 3782 | Proof. pose proof (bq_spec w). pose proof (wb_le w). lia. Qed. | ||
| 3784 | (* Lemma T in the shifted frame *) | ||
| 3785 | Lemma bracket_nat w : pj (S w) + 3 * bq (S w) = 44 + 2 * bq w + wsb w + wH w. | ||
| 3786 | Proof. | ||
| 3787 | pose proof (bracket (S w) ltac:(lia)) as H. unfold bracket_ok in H. apply Z.eqb_eq in H. | ||
| 3788 | replace (S w - 1) with w in H by lia. | ||
| 3789 | pose proof (bq_spec w). pose proof (bq_spec (S w)). lia. | ||
| 3790 | Qed. | ||
| 3792 | Definition nofix (Z : list unt) (D J m : nat) : Prop := | ||
| 3793 | forall A Y, IncN m Z (Ps A ++ Y) -> notP Y -> m <> D + pj J + 3 * A. | ||
| 3795 | (* the zone of interval J after m carries, seen from position p *) | ||
| 3796 | Definition ZoneR (J m p : nat) (u : list unt) : Prop := | ||
| 3797 | exists Z D A Y, CSreach Z D J /\ IncN m Z (Ps A ++ Y) /\ notP Y /\ | ||
| 3798 | (forall m', m' < m -> nofix Z D J m') /\ p <= 44 + D + A /\ u = Ps (44 + D + A - p) ++ Y. | ||
| 3800 | (* the zone of interval 0 (the partial interval before the first | ||
| 3801 | absorption): the counter D0 D0 D1^4 = bin 60 after m carries *) | ||
| 3802 | Definition Zone0 (m p : nat) (u : list unt) : Prop := m <= 33 /\ p <= 44 /\ u = Ps (44 - p) ++ bin (60 + m). | ||
| 3804 | (* the word from position p upward, where w is the youngest wall in it and | ||
| 3805 | has received R carries since its birth *) | ||
| 3806 | Fixpoint WdR (w p R : nat) (u : list unt) : Prop := | ||
| 3807 | (exists Z D, CSreach Z D (S w) /\ Rab w D <= R /\ ZoneR (S w) (R - Rab w D) p u) \/ | ||
| 3808 | ((forall Z D, CSreach Z D (S w) -> R < Rab w D) /\ p <= posw w R /\ | ||
| 3809 | exists u', u = Ps (posw w R - p) ++ wallu (Nat.odd (R + wsb w)) :: u' /\ | ||
| 3810 | match w with | ||
| 3811 | | O => Zone0 (3 * fw 0 R) (S (posw 0 R)) u' | ||
| 3812 | | S w' => WdR w' (S (posw w R)) (wH w' + 3 * fw w R) u' | ||
| 3813 | end). | ||
| 3815 | Lemma WdR_eq w p R u : WdR w p R u <-> | ||
| 3816 | (exists Z D, CSreach Z D (S w) /\ Rab w D <= R /\ ZoneR (S w) (R - Rab w D) p u) \/ | ||
| 3817 | ((forall Z D, CSreach Z D (S w) -> R < Rab w D) /\ p <= posw w R /\ | ||
| 3818 | exists u', u = Ps (posw w R - p) ++ wallu (Nat.odd (R + wsb w)) :: u' /\ | ||
| 3819 | match w with | ||
| 3820 | | O => Zone0 (3 * fw 0 R) (S (posw 0 R)) u' | ||
| 3821 | | S w' => WdR w' (S (posw w R)) (wH w' + 3 * fw w R) u' | ||
| 3822 | end). | ||
| 3823 | Proof. destruct w; reflexivity. Qed. | ||
| 3825 | (* the precondition of a carry: a zone above may take one more carry *) | ||
| 3826 | Definition Can (w R : nat) : Prop := | ||
| 3827 | forall Z D, CSreach Z D (S w) -> Rab w D <= R -> | ||
| 3828 | (exists Y', IncN (S (R - Rab w D)) Z Y') /\ nofix Z D (S w) (R - Rab w D). | ||
| 3830 | (* ---- small word lemmas ---- *) | ||
| 3832 | Lemma Inc_Ps a y y' : Inc y y' -> Inc (Ps a ++ y) (Ps a ++ y'). | ||
| 3833 | Proof. intros H. apply IncN_1_inv. apply IncN_Ps. apply IncN_1. exact H. Qed. | ||
| 3835 | Lemma Ps_snoc a x : Ps a ++ uP :: x = Ps (S a) ++ x. | ||
| 3836 | Proof. induction a as [|a IH]; [reflexivity|]. cbn [Ps app]. rewrite IH. reflexivity. Qed. | ||
| 3838 | Lemma Ps_P_cons n y t : Ps n ++ y = uP :: t -> notP y -> 1 <= n /\ t = Ps (n - 1) ++ y. | ||
| 3839 | Proof. | ||
| 3840 | intros E N. destruct n as [|n]. | ||
| 3841 | - cbn in E. subst y. contradiction. | ||
| 3842 | - cbn in E. injection E as E. split; [lia|]. replace (S n - 1) with n by lia. auto. | ||
| 3843 | Qed. | ||
| 3845 | Lemma notP_wall b x : notP (wallu b :: x). | ||
| 3846 | Proof. destruct b; exact I. Qed. | ||
| 3848 | Lemma shift_notP Y Z' : notP Y -> shift Y = Some Z' -> notP Z'. | ||
| 3849 | Proof. | ||
| 3850 | intros N H. destruct Y as [|u Y]; cbn in H. | ||
| 3851 | - injection H as <-. exact I. | ||
| 3852 | - destruct u; try discriminate; cbn in N; try contradiction. | ||
| 3853 | + destruct (shift Y); [|discriminate]. injection H as <-. exact I. | ||
| 3854 | + injection H as <-. exact I. | ||
| 3855 | Qed. | ||
| 3857 | Lemma Ps_le a b y y' : Ps a ++ y = Ps b ++ y' -> notP y' -> a <= b. | ||
| 3858 | Proof. | ||
| 3859 | revert b; induction a as [|a IH]; intros b E N; [lia|]. | ||
| 3860 | destruct b as [|b]; cbn in E. | ||
| 3861 | - subst y'. contradiction. | ||
| 3862 | - injection E as E. apply IH in E; [lia|exact N]. | ||
| 3863 | Qed. | ||
| 3865 | Lemma fw_even w R : Nat.odd (R + wsb w) = false -> fw w (S R) = fw w R. | ||
| 3866 | Proof. | ||
| 3867 | intros H. unfold fw. assert (He : Nat.even (R + wsb w) = true) by (rewrite <- Nat.negb_odd, H; reflexivity). | ||
| 3868 | apply Nat.even_spec in He. destruct He as [k Hk]. | ||
| 3869 | replace (S R + wsb w) with (1 + k * 2) by lia. rewrite Hk. | ||
| 3870 | rewrite Nat.div_add by lia. rewrite (Nat.mul_comm 2 k), Nat.div_mul by lia. reflexivity. | ||
| 3871 | Qed. | ||
| 3873 | Lemma fw_odd w R : Nat.odd (R + wsb w) = true -> fw w (S R) = S (fw w R). | ||
| 3874 | Proof. | ||
| 3875 | intros H. unfold fw. apply Nat.odd_spec in H. destruct H as [k Hk]. | ||
| 3876 | replace (S R + wsb w) with (0 + (k + 1) * 2) by lia. rewrite Hk. | ||
| 3877 | rewrite Nat.div_add by lia. replace (2 * k + 1) with (1 + k * 2) by lia. | ||
| 3878 | rewrite Nat.div_add by lia. change (0 / 2) with O. change (1 / 2) with O. lia. | ||
| 3879 | Qed. | ||
| 3881 | Lemma odd_S_false w R : Nat.odd (R + wsb w) = true -> Nat.odd (S R + wsb w) = false. | ||
| 3882 | Proof. intros H. replace (S R + wsb w) with (S (R + wsb w)) by lia. rewrite Nat.odd_succ, <- Nat.negb_odd, H. reflexivity. Qed. | ||
| 3884 | Lemma odd_S_true w R : Nat.odd (R + wsb w) = false -> Nat.odd (S R + wsb w) = true. | ||
| 3885 | Proof. intros H. replace (S R + wsb w) with (S (R + wsb w)) by lia. rewrite Nat.odd_succ, <- Nat.negb_odd, H. reflexivity. Qed. | ||
| 3887 | Lemma fw_mono w R R' : R <= R' -> fw w R <= fw w R'. | ||
| 3888 | Proof. intros H. unfold fw. apply Nat.Div0.div_le_mono. lia. Qed. | ||
| 3890 | Lemma fw_add3 w R : S (fw w R) <= fw w (R + 3). | ||
| 3891 | Proof. | ||
| 3892 | unfold fw. replace (R + 3 + wsb w) with ((R + wsb w + 1) + 1 * 2) by lia. | ||
| 3893 | rewrite Nat.div_add by lia. pose proof (Nat.Div0.div_le_mono (R + wsb w) (R + wsb w + 1) 2 ltac:(lia)). lia. | ||
| 3894 | Qed. | ||
| 3896 | Lemma Rab_parity w D R : Nat.odd (R + wsb w) = false -> R < Rab w D -> S R < Rab w D. | ||
| 3897 | Proof. | ||
| 3898 | intros Ho HR. pose proof (wsb_le w). pose proof (bq_le w). unfold Rab in *. | ||
| 3899 | assert (He : Nat.even (R + wsb w) = true) by (rewrite <- Nat.negb_odd, Ho; reflexivity). | ||
| 3900 | apply Nat.even_spec in He. destruct He as [k Hk]. | ||
| 3901 | destruct (Nat.eq_dec (S R) (2 * (44 + D - bq w) - wsb w)) as [E|E]; [|lia]. | ||
| 3902 | exfalso. assert (2 * k + 1 = 2 * (44 + D - bq w)) by lia. lia. | ||
| 3903 | Qed. | ||
| 3905 | (* below the least fixed point: m <= c + 3 A(m) *) | ||
| 3906 | Lemma below Z D J ms As Ys : IncN ms Z (Ps As ++ Ys) -> notP Ys -> | ||
| 3907 | (forall m', m' < ms -> nofix Z D J m') -> | ||
| 3908 | forall m A Y, m <= ms -> IncN m Z (Ps A ++ Y) -> notP Y -> m <= D + pj J + 3 * A. | ||
| 3909 | Proof. | ||
| 3910 | intros Hs Ns Hmin m. induction m as [|m IH]; intros A Y Hm H N; [lia|]. | ||
| 3911 | replace (S m) with (m + 1) in H by lia. destruct (IncN_split _ _ _ _ H) as [W [H1 H2]]. | ||
| 3912 | destruct (leading_P W) as [A0 [Y0 [EW N0]]]. subst W. | ||
| 3913 | specialize (IH A0 Y0 ltac:(lia) H1 N0). | ||
| 3914 | assert (Hne : m <> D + pj J + 3 * A0) by (apply (Hmin m ltac:(lia) A0 Y0 H1 N0)). | ||
| 3915 | destruct (IncN_Ps_inv _ _ _ _ H2) as [y' [Ey _]]. | ||
| 3916 | pose proof (Ps_le _ _ _ _ (eq_sym Ey) N) as Hle. lia. | ||
| 3917 | Qed. | ||
| 3919 | (* the zone state at an interval and its step *) | ||
| 3920 | Lemma zone_at J : 1 <= J -> exists Z D Z' D', CSreach Z D J /\ cs_step Z D J Z' D' (S J) /\ CSreach Z' D' (S J). | ||
| 3921 | Proof. | ||
| 3922 | intros HJ. destruct (zone_forever J HJ) as [Z [D H]]. destruct (CS_next _ _ _ H) as [Z' [D' Hs]]. | ||
| 3923 | exists Z, D, Z', D'. split; [exact H|split; [exact Hs|econstructor; eauto]]. | ||
| 3924 | Qed. | ||
| 3926 | (* ===================================================================== *) | ||
| 3927 | (* 31. The cascade: one carry at the bottom of the word above a position. *) | ||
| 3928 | (* ===================================================================== *) | ||
| 3930 | Lemma WdR_pop w p R t : WdR w p R (uP :: t) -> WdR w (S p) R t. | ||
| 3931 | Proof. | ||
| 3932 | rewrite !WdR_eq. intros [[Z [D [H1 [H2 [Z0 [D0 [A [Y [G1 [G2 [G3 [G4 [G5 E]]]]]]]]]]]]]|[H1 [H2 [u' [E H3]]]]]. | ||
| 3933 | - left. exists Z, D. split; [exact H1|split; [exact H2|]]. | ||
| 3934 | destruct (Ps_P_cons _ _ _ (eq_sym E) G3) as [Hn Et]. | ||
| 3935 | exists Z0, D0, A, Y. split; [exact G1|]. split; [exact G2|]. split; [exact G3|]. split; [exact G4|]. | ||
| 3936 | split; [lia|]. replace (44 + D0 + A - S p) with (44 + D0 + A - p - 1) by lia. exact Et. | ||
| 3937 | - right. destruct (Ps_P_cons _ _ _ (eq_sym E) (notP_wall _ _)) as [Hn Et]. | ||
| 3938 | split; [exact H1|split; [lia|]]. exists u'. split; [|exact H3]. | ||
| 3939 | replace (posw w R - S p) with (posw w R - p - 1) by lia. exact Et. | ||
| 3940 | Qed. | ||
| 3942 | Lemma bin_notP v : notP (bin v). | ||
| 3943 | Proof. | ||
| 3944 | destruct v as [|v]; [exact I|]. rewrite bin_pos by lia. unfold dig. destruct (Nat.eqb _ _); exact I. | ||
| 3945 | Qed. | ||
| 3947 | Lemma Ps_P_cons' n y : 1 <= n -> exists t, Ps n ++ y = uP :: t. | ||
| 3948 | Proof. intros H. destruct n as [|n]; [lia|]. exists (Ps n ++ y). reflexivity. Qed. | ||
| 3950 | (* one carry into the zone part *) | ||
| 3951 | Lemma zone_carry J m p u : ZoneR J m p u -> | ||
| 3952 | (forall Z D, CSreach Z D J -> (exists Y', IncN (S m) Z Y') /\ nofix Z D J m) -> | ||
| 3953 | exists u', Inc u u' /\ ZoneR J (S m) p u'. | ||
| 3954 | Proof. | ||
| 3955 | intros [Z [D [A [Y [HR [HI [HN [Hmin [Hp Eu]]]]]]]]] HC. subst u. | ||
| 3956 | destruct (HC Z D HR) as [[Y' HY'] Hnf]. | ||
| 3957 | replace (S m) with (m + 1) in HY' by lia. | ||
| 3958 | destruct (IncN_split _ _ _ _ HY') as [W [H1 H2]]. | ||
| 3959 | pose proof (IncN_det _ _ _ _ H1 HI) as EW. subst W. | ||
| 3960 | destruct (IncN_Ps_inv _ _ _ _ H2) as [y1 [Ey1 Hy1]]. subst Y'. | ||
| 3961 | apply IncN_1_inv in Hy1. | ||
| 3962 | destruct (leading_P y1) as [dA [Y2 [Ey2 N2]]]. subst y1. | ||
| 3963 | exists (Ps (44 + D + (A + dA) - p) ++ Y2). split. | ||
| 3964 | - replace (Ps (44 + D + (A + dA) - p) ++ Y2) with (Ps (44 + D + A - p) ++ (Ps dA ++ Y2)). | ||
| 3965 | + apply Inc_Ps. exact Hy1. | ||
| 3966 | + rewrite Ps_add. replace (44 + D + A - p + dA) with (44 + D + (A + dA) - p) by lia. reflexivity. | ||
| 3967 | - exists Z, D, (A + dA), Y2. split; [exact HR|]. split. | ||
| 3968 | + replace (S m) with (m + 1) by lia. eapply IncN_add; [exact HI|]. | ||
| 3969 | rewrite <- Ps_add. apply IncN_Ps. apply IncN_1. exact Hy1. | ||
| 3970 | + split; [exact N2|]. split. | ||
| 3971 | * intros m' Hm'. destruct (Nat.eq_dec m' m) as [->|Hne]; [exact Hnf|]. apply Hmin. lia. | ||
| 3972 | * split; [lia|reflexivity]. | ||
| 3973 | Qed. | ||
| 3975 | Lemma Can_lt w' R0 Z D ms As Ys : | ||
| 3976 | CSreach Z D (S w') -> IncN ms Z (Ps As ++ Ys) -> | ||
| 3977 | (forall m', m' < ms -> nofix Z D (S w') m') -> | ||
| 3978 | R0 < Rab w' D + ms -> Can w' R0. | ||
| 3979 | Proof. | ||
| 3980 | intros HR HI Hmin Hlt Z0 D0 H0 Hab. | ||
| 3981 | destruct (CSreach_det _ _ _ H0 _ _ HR) as [-> ->]. split. | ||
| 3982 | - apply (IncN_le ms _ _ (Ps As ++ Ys)); [lia|exact HI]. | ||
| 3983 | - apply Hmin. lia. | ||
| 3984 | Qed. | ||
| 3986 | Lemma cs_step_min Z D j Z' D' j' : cs_step Z D j Z' D' j' -> | ||
| 3987 | exists ms As Ys, IncN ms Z (Ps As ++ Ys) /\ notP Ys /\ ms = D + pj j + 3 * As /\ | ||
| 3988 | (forall m', m' < ms -> nofix Z D j m') /\ shift Ys = Some Z' /\ D' = D + As. | ||
| 3989 | Proof. | ||
| 3990 | intros [ms [As [Ys [H1 [H2 [H3 [H4 [H5 [H6 _]]]]]]]]]. | ||
| 3991 | exists ms, As, Ys. split; [exact H1|]. split; [exact H2|]. split; [exact H3|]. | ||
| 3992 | split; [|split; [exact H5|exact H6]]. | ||
| 3993 | intros m' Hm' A' Y' HI HN. exact (H4 m' A' Y' Hm' HI HN). | ||
| 3994 | Qed. | ||
| 3996 | Lemma fw_val w R k : R + wsb w = 2 * k + 1 -> fw w R = k. | ||
| 3997 | Proof. intros H. unfold fw. rewrite H. symmetry. apply Nat.div_unique with 1%nat; lia. Qed. | ||
| 3999 | Lemma cascade w : forall p R u, WdR w p R u -> Can w R -> exists u', Inc u u' /\ WdR w p (S R) u'. | ||
| 4000 | Proof. | ||
| 4001 | induction w as [|w' IH]; intros p R u HW HC; apply WdR_eq in HW; | ||
| 4002 | destruct HW as [[Z [D [HR [Hab HZ]]]]|[Hlive [Hp [u' [Eu Hrest]]]]]. | ||
| 4003 | - destruct (zone_carry _ _ _ _ HZ) as [u'' [Hi HZ']]. | ||
| 4004 | + intros Z0 D0 HR0. destruct (CSreach_det _ _ _ HR _ _ HR0) as [<- <-]. exact (HC Z D HR Hab). | ||
| 4005 | + exists u''. split; [exact Hi|]. apply WdR_eq. left. exists Z, D. split; [exact HR|]. split; [lia|]. | ||
| 4006 | replace (S R - Rab 0 D) with (S (R - Rab 0 D)) by lia. exact HZ'. | ||
| 4007 | - (* wall 0, live: its rest is the counter of interval 0 *) | ||
| 4008 | assert (Eb0 : bq 0 = 33) by reflexivity. assert (Es0 : wsb 0 = 1%nat) by reflexivity. | ||
| 4009 | pose proof (Hlive _ _ CS1) as Hl0. unfold Rab in Hl0. rewrite Eb0, Es0 in Hl0. | ||
| 4010 | destruct Hrest as [Hm0 [Hp0 Eu']]. subst u'. | ||
| 4011 | set (f := fw 0 R) in *. set (pW := posw 0 R) in *. | ||
| 4012 | assert (Hpw : pW = 33 + f) by (unfold pW, posw; rewrite Eb0; reflexivity). | ||
| 4013 | destruct (Nat.odd (R + wsb 0)) eqn:Ho. | ||
| 4014 | + destruct (proj1 (Nat.odd_spec _) Ho) as [k Hk]. | ||
| 4015 | assert (Ef : f = k) by (apply fw_val; exact Hk). | ||
| 4016 | rewrite Es0 in Hk. | ||
| 4017 | assert (H3 : IncN 3 (Ps (44 - S pW) ++ bin (60 + 3 * f)) (Ps (44 - S pW) ++ bin (60 + 3 * f + 3))). | ||
| 4018 | { apply IncN_Ps. apply IncN_bin. } | ||
| 4019 | try rewrite Ho in Eu. cbn [wallu] in Eu. subst u. | ||
| 4020 | destruct (Nat.eq_dec (S R) 21) as [Eabs|Hmv]. | ||
| 4021 | * assert (Ef10 : f = 10) by lia. | ||
| 4022 | assert (Ez : 44 - S pW = O) by lia. rewrite Ez in H3 |- *. cbn [Ps app] in H3 |- *. | ||
| 4023 | assert (Eb : bin (60 + 3 * f + 3) = [uD1; uD0; uD1; uD1; uD1; uD0; uD1]) by (rewrite Ef10; reflexivity). | ||
| 4024 | rewrite Eb in H3. | ||
| 4025 | exists (Ps (S pW - p) ++ [uS1; uD0; uD1; uD1; uD1; uD0; uD1]). split. | ||
| 4026 | -- replace (Ps (S pW - p) ++ [uS1; uD0; uD1; uD1; uD1; uD0; uD1]) | ||
| 4027 | with (Ps (pW - p) ++ uP :: [uS1; uD0; uD1; uD1; uD1; uD0; uD1]) | ||
| 4028 | by (rewrite Ps_snoc; replace (S (pW - p)) with (S pW - p) by lia; reflexivity). | ||
| 4029 | apply Inc_Ps. eapply Inc_W3; [exact H3|reflexivity]. | ||
| 4030 | -- apply WdR_eq. left. exists [uS1; uD0; uD1; uD1; uD1; uD0; uD1], O. split; [constructor|]. | ||
| 4031 | split; [unfold Rab; rewrite Eb0, Es0; lia|]. | ||
| 4032 | replace (S R - Rab 0 0) with O by (unfold Rab; rewrite Eb0, Es0; lia). | ||
| 4033 | exists [uS1; uD0; uD1; uD1; uD1; uD0; uD1], O, O, [uS1; uD0; uD1; uD1; uD1; uD0; uD1]. | ||
| 4034 | split; [constructor|]. split; [constructor|]. split; [exact I|]. split; [intros; lia|]. | ||
| 4035 | split; [lia|]. replace (44 + 0 + 0 - p) with (S pW - p) by lia. reflexivity. | ||
| 4036 | * assert (Hx : 1 <= 44 - S pW) by lia. | ||
| 4037 | destruct (Ps_P_cons' _ (bin (60 + 3 * f + 3)) Hx) as [t Et]. rewrite Et in H3. | ||
| 4038 | exists (Ps (S pW - p) ++ uSP :: t). split. | ||
| 4039 | -- replace (Ps (S pW - p) ++ uSP :: t) with (Ps (pW - p) ++ uP :: uSP :: t) | ||
| 4040 | by (rewrite Ps_snoc; replace (S (pW - p)) with (S pW - p) by lia; reflexivity). | ||
| 4041 | apply Inc_Ps. eapply Inc_W3; [exact H3|reflexivity]. | ||
| 4042 | -- apply WdR_eq. right. | ||
| 4043 | assert (Ep : posw 0 (S R) = S pW) by (unfold pW, posw; rewrite fw_odd by exact Ho; lia). | ||
| 4044 | split; [intros Z0 D0 Hc0; unfold Rab; rewrite Eb0, Es0; lia|]. | ||
| 4045 | split; [rewrite Ep; lia|]. | ||
| 4046 | exists t. split. | ||
| 4047 | ++ rewrite Ep, (odd_S_false _ _ Ho). reflexivity. | ||
| 4048 | ++ rewrite Ep. rewrite (fw_odd _ _ Ho). fold f. | ||
| 4049 | assert (Ht : t = Ps (44 - S pW - 1) ++ bin (60 + 3 * f + 3)). | ||
| 4050 | { destruct (Ps_P_cons _ _ _ Et (bin_notP _)) as [_ E2]. exact E2. } | ||
| 4051 | split; [lia|]. split; [lia|]. rewrite Ht. | ||
| 4052 | replace (44 - S pW - 1) with (44 - S (S pW)) by lia. | ||
| 4053 | replace (60 + 3 * S f) with (60 + 3 * f + 3) by lia. reflexivity. | ||
| 4054 | + try rewrite Ho in Eu. cbn [wallu] in Eu. subst u. | ||
| 4055 | exists (Ps (pW - p) ++ uW :: Ps (44 - S pW) ++ bin (60 + 3 * f)). split. | ||
| 4056 | * apply Inc_Ps. constructor. | ||
| 4057 | * apply WdR_eq. right. | ||
| 4058 | assert (Ep : posw 0 (S R) = pW) by (unfold pW, posw; rewrite fw_even by exact Ho; reflexivity). | ||
| 4059 | split; [intros Z0 D0 H0; apply Rab_parity; [exact Ho|exact (Hlive Z0 D0 H0)]|]. | ||
| 4060 | split; [rewrite Ep; exact Hp|]. | ||
| 4061 | eexists. split. | ||
| 4062 | -- rewrite Ep, (odd_S_true _ _ Ho). reflexivity. | ||
| 4063 | -- rewrite Ep, (fw_even _ _ Ho). fold f. split; [exact Hm0|]. split; [exact Hp0|]. reflexivity. | ||
| 4064 | - destruct (zone_carry _ _ _ _ HZ) as [u'' [Hi HZ']]. | ||
| 4065 | + intros Z0 D0 HR0. destruct (CSreach_det _ _ _ HR _ _ HR0) as [<- <-]. exact (HC Z D HR Hab). | ||
| 4066 | + exists u''. split; [exact Hi|]. apply WdR_eq. left. exists Z, D. split; [exact HR|]. split; [lia|]. | ||
| 4067 | replace (S R - Rab (S w') D) with (S (R - Rab (S w') D)) by lia. exact HZ'. | ||
| 4068 | - (* a live wall W = S w' *) | ||
| 4069 | set (W := S w') in *. | ||
| 4070 | set (pW := posw W R) in *. set (f := fw W R) in *. | ||
| 4071 | change (WdR w' (S pW) (wH w' + 3 * f) u') in Hrest. | ||
| 4072 | set (R' := wH w' + 3 * f) in *. | ||
| 4073 | destruct (Nat.odd (R + wsb W)) eqn:Ho. | ||
| 4074 | + (* W: it fires *) | ||
| 4075 | destruct (proj1 (Nat.odd_spec _) Ho) as [k Hk]. | ||
| 4076 | assert (Ef : f = k) by (apply fw_val; exact Hk). | ||
| 4077 | destruct (zone_at W ltac:(unfold W; lia)) as [Z [D [Z1 [D1 [HR [Hst HR1]]]]]]. | ||
| 4078 | destruct (cs_step_min _ _ _ _ _ _ Hst) as [ms [As [Ys [HIs [HNs [Ems [Hmins [Hshs ED]]]]]]]]. | ||
| 4079 | pose proof (Hlive Z1 D1 HR1) as HlR. | ||
| 4080 | pose proof (bracket_nat w') as Hbr. fold W in Hbr. | ||
| 4081 | pose proof (bq_le W). pose proof (bq_le w'). pose proof (wsb_le W). pose proof (wsb_le w'). | ||
| 4082 | assert (Hpw : pW = bq W + f) by reflexivity. | ||
| 4083 | unfold Rab in HlR. | ||
| 4084 | assert (Hkey : ms + Rab w' D = R' + 3 * (44 + D1 - bq W - f)) by (unfold Rab, R'; lia). | ||
| 4085 | assert (Hf1 : f + 1 <= 44 + D1 - bq W) by lia. | ||
| 4086 | destruct (IH _ _ _ Hrest (Can_lt w' R' Z D ms As Ys HR HIs Hmins ltac:(lia))) as [u1 [Hi1 HW1]]. | ||
| 4087 | destruct (IH _ _ _ HW1 (Can_lt w' (S R') Z D ms As Ys HR HIs Hmins ltac:(lia))) as [u2 [Hi2 HW2]]. | ||
| 4088 | destruct (IH _ _ _ HW2 (Can_lt w' (S (S R')) Z D ms As Ys HR HIs Hmins ltac:(lia))) as [u3 [Hi3 HW3]]. | ||
| 4089 | assert (HW3' := HW3). apply WdR_eq in HW3'. | ||
| 4090 | try rewrite Ho in Eu. cbn [wallu] in Eu. subst u. | ||
| 4091 | destruct (Nat.eq_dec (S R) (2 * (44 + D1 - bq W) - wsb W)) as [Eabs|Hmv]. | ||
| 4092 | * (* the absorbing firing *) | ||
| 4093 | assert (Hm3 : S (S (S R')) - Rab w' D = ms) by (unfold Rab in *; lia). | ||
| 4094 | destruct HW3' as [[Z3 [D3 [HR3 [Hab3 [Z4 [D4 [A4 [Y4 [G1 [G2 [G3 [G4 [G5 E4]]]]]]]]]]]]]|[Hl3 _]]. | ||
| 4095 | 2:{ exfalso. specialize (Hl3 Z D HR). unfold Rab in *. lia. } | ||
| 4096 | destruct (CSreach_det _ _ _ HR3 _ _ HR) as [-> ->]. | ||
| 4097 | destruct (CSreach_det _ _ _ G1 _ _ HR) as [-> ->]. | ||
| 4098 | rewrite Hm3 in G2. pose proof (IncN_det _ _ _ _ G2 HIs) as EI. | ||
| 4099 | destruct (Ps_notP_inj _ _ _ _ EI G3 HNs) as [-> ->]. | ||
| 4100 | assert (Ez : 44 + D + As - S pW = O) by lia. rewrite Ez in E4. cbn [Ps app] in E4. subst u3. | ||
| 4101 | exists (Ps (S pW - p) ++ Z1). split. | ||
| 4102 | -- replace (Ps (S pW - p) ++ Z1) with (Ps (pW - p) ++ uP :: Z1) | ||
| 4103 | by (rewrite Ps_snoc; replace (S (pW - p)) with (S pW - p) by lia; reflexivity). | ||
| 4104 | apply Inc_Ps. eapply Inc_W; [exact Hi1|exact Hi2|exact Hi3|exact Hshs]. | ||
| 4105 | -- apply WdR_eq. left. exists Z1, D1. split; [exact HR1|]. split; [unfold Rab; lia|]. | ||
| 4106 | replace (S R - Rab W D1) with O by (unfold Rab; lia). | ||
| 4107 | exists Z1, D1, O, Z1. split; [exact HR1|]. split; [constructor|]. | ||
| 4108 | split; [exact (shift_notP _ _ HNs Hshs)|]. split; [intros; lia|]. | ||
| 4109 | split; [lia|]. replace (44 + D1 + 0 - p) with (S pW - p) by lia. reflexivity. | ||
| 4110 | * (* the wall moves up *) | ||
| 4111 | assert (Hmv' : S R < 2 * (44 + D1 - bq W) - wsb W) by lia. | ||
| 4112 | assert (Hf2 : f + 2 <= 44 + D1 - bq W) by lia. | ||
| 4113 | assert (Ht : exists t, u3 = uP :: t). | ||
| 4114 | { destruct HW3' as [[Z3 [D3 [HR3 [Hab3 [Z4 [D4 [A4 [Y4 [G1 [G2 [G3 [G4 [G5 E4]]]]]]]]]]]]]|[Hl3 [Hp3 [u4 [E4 _]]]]]. | ||
| 4115 | - destruct (CSreach_det _ _ _ HR3 _ _ HR) as [-> ->]. | ||
| 4116 | destruct (CSreach_det _ _ _ G1 _ _ HR) as [-> ->]. | ||
| 4117 | set (m3 := S (S (S R')) - Rab w' D) in *. | ||
| 4118 | assert (Hm3 : m3 < ms) by (unfold m3, Rab in *; lia). | ||
| 4119 | pose proof (below Z D W ms As Ys HIs HNs Hmins m3 A4 Y4 ltac:(lia) G2 G3) as Hb. | ||
| 4120 | pose proof (Hmins m3 Hm3 A4 Y4 G2 G3) as Hn. | ||
| 4121 | assert (Hx : 1 <= 44 + D + A4 - S pW) by (unfold m3, Rab in *; lia). | ||
| 4122 | destruct (Ps_P_cons' (44 + D + A4 - S pW) Y4 Hx) as [t Et]. exists t. rewrite E4. exact Et. | ||
| 4123 | - assert (Hlv : forall Z0 D0, CSreach Z0 D0 (S w') -> R' < Rab w' D0). | ||
| 4124 | { intros Z0 D0 Hc0. specialize (Hl3 Z0 D0 Hc0). lia. } | ||
| 4125 | apply WdR_eq in Hrest. | ||
| 4126 | destruct Hrest as [[Z5 [D5 [HR5 [Hab5 _]]]]|[_ [Hp5 _]]]. | ||
| 4127 | + exfalso. specialize (Hlv Z5 D5 HR5). lia. | ||
| 4128 | + pose proof (fw_add3 w' R'). unfold posw in Hp5, E4. | ||
| 4129 | assert (Hx : 1 <= bq w' + fw w' (S (S (S R'))) - S pW). | ||
| 4130 | { replace (S (S (S R'))) with (R' + 3) by lia. lia. } | ||
| 4131 | destruct (Ps_P_cons' _ (wallu (Nat.odd (S (S (S R')) + wsb w')) :: u4) Hx) as [t Et]. exists t. rewrite E4. exact Et. } | ||
| 4132 | destruct Ht as [t Et]. subst u3. | ||
| 4133 | exists (Ps (S pW - p) ++ uSP :: t). split. | ||
| 4134 | -- replace (Ps (S pW - p) ++ uSP :: t) with (Ps (pW - p) ++ uP :: uSP :: t) | ||
| 4135 | by (rewrite Ps_snoc; replace (S (pW - p)) with (S pW - p) by lia; reflexivity). | ||
| 4136 | apply Inc_Ps. eapply Inc_W; [exact Hi1|exact Hi2|exact Hi3|reflexivity]. | ||
| 4137 | -- apply WdR_eq. right. | ||
| 4138 | assert (Ep : posw W (S R) = S pW) by (unfold pW, posw; rewrite fw_odd by exact Ho; lia). | ||
| 4139 | split; [intros Z0 D0 Hc0; destruct (CSreach_det _ _ _ Hc0 _ _ HR1) as [-> ->]; unfold Rab; lia|]. | ||
| 4140 | split; [rewrite Ep; lia|]. | ||
| 4141 | exists t. split. | ||
| 4142 | ++ rewrite Ep, (odd_S_false _ _ Ho). reflexivity. | ||
| 4143 | ++ change (WdR w' (S (posw W (S R))) (wH w' + 3 * fw W (S R)) t). | ||
| 4144 | rewrite Ep. rewrite (fw_odd _ _ Ho). fold f. | ||
| 4145 | replace (wH w' + 3 * S f) with (S (S (S R'))) by (unfold R'; lia). | ||
| 4146 | apply WdR_pop. exact HW3. | ||
| 4147 | + (* SP: it becomes W *) | ||
| 4148 | try rewrite Ho in Eu. cbn [wallu] in Eu. subst u. | ||
| 4149 | exists (Ps (pW - p) ++ uW :: u'). split. | ||
| 4150 | * apply Inc_Ps. constructor. | ||
| 4151 | * apply WdR_eq. right. | ||
| 4152 | assert (Ep : posw W (S R) = pW) by (unfold pW, posw; rewrite fw_even by exact Ho; reflexivity). | ||
| 4153 | split; [intros Z0 D0 H0; apply Rab_parity; [exact Ho|exact (Hlive Z0 D0 H0)]|]. | ||
| 4154 | split; [rewrite Ep; exact Hp|]. | ||
| 4155 | exists u'. split. | ||
| 4156 | -- rewrite Ep, (odd_S_true _ _ Ho). reflexivity. | ||
| 4157 | -- change (WdR w' (S (posw W (S R))) (wH w' + 3 * fw W (S R)) u'). | ||
| 4158 | rewrite Ep, (fw_even _ _ Ho). exact Hrest. | ||
| 4159 | Qed. | ||
| 4161 | (* ===================================================================== *) | ||
| 4162 | (* 32. The record invariant (proof.md 7) and AbsDefined. *) | ||
| 4163 | (* ===================================================================== *) | ||
| 4165 | Lemma cascadeN w p R u t : WdR w p R u -> (forall i, i < t -> Can w (R + i)) -> | ||
| 4166 | exists u', IncN t u u' /\ WdR w p (R + t) u'. | ||
| 4167 | Proof. | ||
| 4168 | revert R u. induction t as [|t IH]; intros R u H HC. | ||
| 4169 | - exists u. split; [constructor|]. rewrite Nat.add_0_r. exact H. | ||
| 4170 | - destruct (cascade w p R u H) as [u1 [Hi H1]]; [rewrite <- (Nat.add_0_r R); apply HC; lia|]. | ||
| 4171 | destruct (IH (S R) u1 H1) as [u2 [Hn H2]]. | ||
| 4172 | { intros i Hi'. replace (S R + i) with (R + S i) by lia. apply HC. lia. } | ||
| 4173 | exists u2. split; [econstructor; eauto|]. replace (R + S t) with (S R + t) by lia. exact H2. | ||
| 4174 | Qed. | ||
| 4176 | Lemma live_small w R : R < 2 * (44 - bq w) - wsb w -> forall Z D, CSreach Z D (S w) -> R < Rab w D. | ||
| 4177 | Proof. intros H Z D _. unfold Rab. pose proof (bq_le w). lia. Qed. | ||
| 4179 | Lemma Can_live w R : R < 2 * (44 - bq w) - wsb w -> Can w R. | ||
| 4180 | Proof. intros H Z D HR Hab. pose proof (live_small w R H Z D HR). lia. Qed. | ||
| 4182 | Lemma Pops_bottom Y k b R u : WdR Y b R u -> R + 3 * k < 2 * (44 - bq Y) - wsb Y -> | ||
| 4183 | exists u', Pops k u u' /\ WdR Y (b + k) (R + 3 * k) u'. | ||
| 4184 | Proof. | ||
| 4185 | revert b R u. induction k as [|k IH]; intros b R u H Hl. | ||
| 4186 | - exists u. split; [reflexivity|]. rewrite !Nat.add_0_r. exact H. | ||
| 4187 | - destruct (cascadeN Y b R u 3 H) as [u3 [H3 HW3]]. | ||
| 4188 | { intros i Hi. apply Can_live. lia. } | ||
| 4189 | assert (Ht : exists t, u3 = uP :: t). | ||
| 4190 | { assert (HW3' := HW3). apply WdR_eq in HW3'. | ||
| 4191 | destruct HW3' as [[Z [D [HR [Hab _]]]]|[_ [Hp [u4 [E4 _]]]]]. | ||
| 4192 | - exfalso. unfold Rab in Hab. pose proof (bq_le Y). lia. | ||
| 4193 | - assert (H' := H). apply WdR_eq in H'. destruct H' as [[Z [D [HR [Hab _]]]]|[_ [Hp0 _]]]. | ||
| 4194 | + exfalso. unfold Rab in Hab. pose proof (bq_le Y). lia. | ||
| 4195 | + pose proof (fw_add3 Y R). unfold posw in Hp0, E4. | ||
| 4196 | destruct (Ps_P_cons' (bq Y + fw Y (R + 3) - b) (wallu (Nat.odd (R + 3 + wsb Y)) :: u4)) as [t Et]; [lia|]. | ||
| 4197 | exists t. rewrite E4. exact Et. } | ||
| 4198 | destruct Ht as [t Et]. subst u3. | ||
| 4199 | destruct (IH (S b) (R + 3) t (WdR_pop _ _ _ _ HW3)) as [u' [Hp Hw]]; [lia|]. | ||
| 4200 | exists u'. split. | ||
| 4201 | + exists t. split; [apply Inc3Pop_of; exact H3|exact Hp]. | ||
| 4202 | + replace (b + S k) with (S b + k) by lia. replace (R + 3 * S k) with (R + 3 + 3 * k) by lia. exact Hw. | ||
| 4203 | Qed. | ||
| 4205 | Lemma WdR_push w p q R0 u bqv sv : WdR w q R0 u -> R0 = wH w -> bq (S w) = bqv -> wsb (S w) = sv -> | ||
| 4206 | sv <= 1 -> p <= bqv -> S bqv = q -> 0 < 2 * (44 - bqv) - sv -> | ||
| 4207 | WdR (S w) p 0 (Ps (bqv - p) ++ wallu (Nat.odd sv) :: u). | ||
| 4208 | Proof. | ||
| 4209 | intros H HR0 Hb Hs Hsv Hp Hq Hl. | ||
| 4210 | assert (E0 : fw (S w) 0 = O) by (unfold fw; rewrite Hs; apply Nat.div_small; lia). | ||
| 4211 | assert (Ep : posw (S w) 0 = bqv) by (unfold posw; rewrite E0, Hb; lia). | ||
| 4212 | apply WdR_eq. right. split; [apply live_small; rewrite Hb, Hs; exact Hl|]. split; [rewrite Ep; exact Hp|]. | ||
| 4213 | exists u. split; [rewrite Ep, Hs; reflexivity|]. | ||
| 4214 | change (WdR w (S (posw (S w) 0)) (wH w + 3 * fw (S w) 0) u). | ||
| 4215 | rewrite E0, Ep, Nat.mul_0_r, Nat.add_0_r, Hq, <- HR0. exact H. | ||
| 4216 | Qed. | ||
| 4218 | Lemma wdata5 w : 5 <= w -> | ||
| 4219 | wb w = nth ((w + 2) mod 8) phb 0%Z /\ wsb w = nth ((w + 2) mod 8) phs O /\ wH w = nth ((w + 2) mod 8) phH O. | ||
| 4220 | Proof. | ||
| 4221 | intros Hw. destruct (Nat.eq_dec w 5) as [->|Hne]; [split; [reflexivity|split; reflexivity]|]. | ||
| 4222 | unfold wb, wsb, wH. destruct (Nat.ltb_spec w 6) as [|_]; [lia|]. | ||
| 4223 | replace ((w + 2) mod 8) with ((w - 6) mod 8); [auto|]. | ||
| 4224 | replace (w + 2) with ((w - 6) + 1 * 8) by lia. rewrite Nat.Div0.mod_add. reflexivity. | ||
| 4225 | Qed. | ||
| 4227 | Lemma wd w r : 5 <= w -> (w + 2) mod 8 = r -> | ||
| 4228 | bq w = Z.to_nat (nth r phb 0%Z + 1) /\ wsb w = nth r phs O /\ wH w = nth r phH O. | ||
| 4229 | Proof. | ||
| 4230 | intros Hw Hr. destruct (wdata5 w Hw) as [E1 [E2 E3]]. rewrite Hr in E1, E2, E3. | ||
| 4231 | split; [unfold bq; rewrite E1; reflexivity|split; assumption]. | ||
| 4232 | Qed. | ||
| 4234 | Lemma mod8_S w r : (w + 2) mod 8 = r -> (S w + 2) mod 8 = (S r) mod 8. | ||
| 4235 | Proof. | ||
| 4236 | intros H. subst r. replace (S w + 2) with ((w + 2) + 1) by lia. | ||
| 4237 | replace (S ((w + 2) mod 8)) with ((w + 2) mod 8 + 1) by lia. | ||
| 4238 | rewrite Nat.Div0.add_mod_idemp_l. reflexivity. | ||
| 4239 | Qed. | ||
| 4241 | Lemma mod8_S' w r r' : (w + 2) mod 8 = r -> S r mod 8 = r' -> (S w + 2) mod 8 = r'. | ||
| 4242 | Proof. intros H1 H2. rewrite (mod8_S _ _ H1). exact H2. Qed. | ||
| 4244 | Definition rbase (t : rt) : nat := match t with YC | YD | YE => O | _ => 1%nat end. | ||
| 4245 | Definition rph (t : rt) : nat := match t with XC | XD | XE => 7%nat | YC | YD | YE => 2%nat | _ => 6%nat end. | ||
| 4247 | Definition RInv (t : rt) (U : list unt) : Prop := | ||
| 4248 | exists Y, 5 <= Y /\ (Y + 2) mod 8 = rph t /\ WdR Y (rbase t) 0 U. | ||
| 4250 | Lemma bq_small w : 5 <= w -> bq w <= 12. | ||
| 4251 | Proof. | ||
| 4252 | intros Hw. destruct (wdata5 w Hw) as [E _]. pose proof (bq_spec w) as H. rewrite E in H. | ||
| 4253 | assert (Hb : forall i, (nth i phb 0%Z <= 10)%Z) by (intros i; do 8 (destruct i as [|i]; [cbn; lia|]); destruct i; cbn; lia). | ||
| 4254 | specialize (Hb ((w + 2) mod 8)). lia. | ||
| 4255 | Qed. | ||
| 4257 | Lemma RInv_step t U : RInv t U -> exists U', Pops (rk t) U U' /\ RInv (rnext t) (rF t ++ U'). | ||
| 4258 | Proof. | ||
| 4259 | intros [Y [HY [Hph HW]]]. | ||
| 4260 | pose proof (bq_small Y HY) as Hbq. pose proof (wsb_le Y) as Hsy. | ||
| 4261 | destruct t; cbn [rk rF rnext rbase rph app] in *; | ||
| 4262 | try (exists U; split; [reflexivity|exists Y; split; [exact HY|split; [exact Hph|exact HW]]]). | ||
| 4263 | - (* XE: 3 pops, then W W P SP *) | ||
| 4264 | destruct (Pops_bottom Y 3 1 0 U HW) as [U' [HP HW']]; [lia|]. change (WdR Y 4 9 U') in HW'. | ||
| 4265 | exists U'. split; [exact HP|]. | ||
| 4266 | destruct (wd Y 7 HY Hph) as [_ [_ HH0]]. cbn in HH0. | ||
| 4267 | pose proof (mod8_S' _ _ 0 Hph eq_refl) as P1. | ||
| 4268 | destruct (wd (S Y) 0 ltac:(lia) P1) as [B1 [S1' H1']]. cbn in B1, S1', H1'. | ||
| 4269 | pose proof (mod8_S' _ _ 1 P1 eq_refl) as P2. | ||
| 4270 | destruct (wd (S (S Y)) 1 ltac:(lia) P2) as [B2 [S2' H2']]. cbn in B2, S2', H2'. | ||
| 4271 | pose proof (mod8_S' _ _ 2 P2 eq_refl) as P3. | ||
| 4272 | destruct (wd (S (S (S Y))) 2 ltac:(lia) P3) as [B3 [S3' _]]. cbn in B3, S3'. | ||
| 4273 | pose proof (WdR_push Y 2 4 9 U' 3 0 HW' (eq_sym HH0) B1 S1' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W1. | ||
| 4274 | pose proof (WdR_push (S Y) 1 2 0 _ 1 1 W1 (eq_sym H1') B2 S2' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W2. | ||
| 4275 | pose proof (WdR_push (S (S Y)) 0 1 0 _ 0 1 W2 (eq_sym H2') B3 S3' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W3. | ||
| 4276 | exists (S (S (S Y))). split; [lia|]. split; [exact P3|]. exact W3. | ||
| 4277 | - (* YE: 12 pops, then W P W P P SP P P P P SP *) | ||
| 4278 | destruct (Pops_bottom Y 12 0 0 U HW) as [U' [HP HW']]; [lia|]. change (WdR Y 12 36 U') in HW'. | ||
| 4279 | exists U'. split; [exact HP|]. | ||
| 4280 | destruct (wd Y 2 HY Hph) as [_ [_ HH0]]. cbn in HH0. | ||
| 4281 | pose proof (mod8_S' _ _ 3 Hph eq_refl) as P1. | ||
| 4282 | destruct (wd (S Y) 3 ltac:(lia) P1) as [B1 [S1' H1']]. cbn in B1, S1', H1'. | ||
| 4283 | pose proof (mod8_S' _ _ 4 P1 eq_refl) as P2. | ||
| 4284 | destruct (wd (S (S Y)) 4 ltac:(lia) P2) as [B2 [S2' H2']]. cbn in B2, S2', H2'. | ||
| 4285 | pose proof (mod8_S' _ _ 5 P2 eq_refl) as P3. | ||
| 4286 | destruct (wd (S (S (S Y))) 5 ltac:(lia) P3) as [B3 [S3' H3']]. cbn in B3, S3', H3'. | ||
| 4287 | pose proof (mod8_S' _ _ 6 P3 eq_refl) as P4. | ||
| 4288 | destruct (wd (S (S (S (S Y)))) 6 ltac:(lia) P4) as [B4 [S4' _]]. cbn in B4, S4'. | ||
| 4289 | pose proof (WdR_push Y 7 12 36 U' 11 0 HW' (eq_sym HH0) B1 S1' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W1. | ||
| 4290 | pose proof (WdR_push (S Y) 4 7 0 _ 6 0 W1 (eq_sym H1') B2 S2' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W2. | ||
| 4291 | pose proof (WdR_push (S (S Y)) 2 4 0 _ 3 1 W2 (eq_sym H2') B3 S3' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W3. | ||
| 4292 | pose proof (WdR_push (S (S (S Y))) 1 2 0 _ 1 1 W3 (eq_sym H3') B4 S4' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W4. | ||
| 4293 | exists (S (S (S (S Y)))). split; [lia|]. split; [exact P4|]. exact W4. | ||
| 4294 | - (* ZE: 2 pops, then P SP *) | ||
| 4295 | destruct (Pops_bottom Y 2 1 0 U HW) as [U' [HP HW']]; [lia|]. change (WdR Y 3 6 U') in HW'. | ||
| 4296 | exists U'. split; [exact HP|]. | ||
| 4297 | destruct (wd Y 6 HY Hph) as [_ [_ HH0]]. cbn in HH0. | ||
| 4298 | pose proof (mod8_S' _ _ 7 Hph eq_refl) as P1. | ||
| 4299 | destruct (wd (S Y) 7 ltac:(lia) P1) as [B1 [S1' _]]. cbn in B1, S1'. | ||
| 4300 | pose proof (WdR_push Y 1 3 6 U' 2 0 HW' (eq_sym HH0) B1 S1' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W1. | ||
| 4301 | exists (S Y). split; [lia|]. split; [exact P1|]. exact W1. | ||
| 4302 | Qed. | ||
| 4304 | Lemma RInv_U0 : RInv XC U0. | ||
| 4305 | Proof. | ||
| 4306 | exists 5. split; [lia|]. split; [reflexivity|]. | ||
| 4307 | assert (W0 : WdR 0 22 0 (Ps 11 ++ uW :: Ps 10 ++ bin 60)). | ||
| 4308 | { apply WdR_eq. right. split; [apply live_small; vm_compute; lia|]. | ||
| 4309 | split; [vm_compute; lia|]. exists (Ps 10 ++ bin 60). split; [reflexivity|]. | ||
| 4310 | split; [vm_compute; lia|]. split; [vm_compute; lia|]. reflexivity. } | ||
| 4311 | pose proof (WdR_push 0 14 22 0 _ 21 1 W0 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W1. | ||
| 4312 | pose proof (WdR_push 1 9 14 0 _ 13 1 W1 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W2. | ||
| 4313 | pose proof (WdR_push 2 5 9 0 _ 8 0 W2 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W3. | ||
| 4314 | pose proof (WdR_push 3 3 5 0 _ 4 1 W3 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W4. | ||
| 4315 | pose proof (WdR_push 4 1 3 0 _ 2 0 W4 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W5. | ||
| 4316 | exact W5. | ||
| 4317 | Qed. | ||
| 4319 | Lemma Pops_det k U U1 U2 : Pops k U U1 -> Pops k U U2 -> U1 = U2. | ||
| 4320 | Proof. | ||
| 4321 | revert U; induction k as [|k IH]; intros U H1 H2; cbn in H1, H2. | ||
| 4322 | - congruence. | ||
| 4323 | - destruct H1 as [V1 [[a1 [b1 [Ha1 [Hb1 Hc1]]]] H1]]. destruct H2 as [V2 [[a2 [b2 [Ha2 [Hb2 Hc2]]]] H2]]. | ||
| 4324 | assert (a1 = a2) by (eapply Inc_det; eauto). subst a2. | ||
| 4325 | assert (b1 = b2) by (eapply Inc_det; eauto). subst b2. | ||
| 4326 | assert (E : uP :: V1 = uP :: V2) by (eapply Inc_det; eauto). injection E as ->. | ||
| 4327 | eapply IH; eauto. | ||
| 4328 | Qed. | ||
| 4330 | Lemma Reach_RInv t U : Reach t U -> RInv t U. | ||
| 4331 | Proof. | ||
| 4332 | induction 1 as [|t U U' HR IH HP]. | ||
| 4333 | - exact RInv_U0. | ||
| 4334 | - destruct (RInv_step t U IH) as [U'' [HP' HI]]. | ||
| 4335 | rewrite (Pops_det _ _ _ _ HP HP'). exact HI. | ||
| 4336 | Qed. | ||
| 4338 | Theorem AbsDefined_proof : AbsDefined. | ||
| 4339 | Proof. | ||
| 4340 | intros t U HR. destruct (RInv_step t U (Reach_RInv t U HR)) as [U' [HP _]]. eauto. | ||
| 426 | Qed. | 4341 | Qed. |
| 428 | Lemma nonhalt: ~halts tm c0. | 4343 | Lemma nonhalt: ~halts tm c0. |
| 429 | Proof. | ||
| 4344 | Proof. apply nonhalt_of_abs, AbsDefined_proof. Qed. | ||
| 430 | eapply sigma_score_unbounded_nonhalt. | ||
| 4346 | (* | ||
| 431 | intros n. | ||
| 4347 | ``` | ||
| 432 | epose proof (Q0_n n) as [_ [_ [_ I1]]]. | ||
| 4348 | 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB | ||
| 433 | unshelve epose proof (I1 (2^n*18+6) _ (2^n*18+5) 1 _ _ _ _) as I1; try lia. | ||
| 4350 | 0 1 | ||
| 434 | eapply (P_spec) in I1. | ||
| 4351 | A 1RB --- | ||
| 435 | rewrite lpow_all0 in I1 by solve_const0_eq. | ||
| 4352 | B 1LC 1RE | ||
| 436 | eexists _,_; split. | ||
| 4353 | C 1LD 0LC | ||
| 437 | - eapply evstep_trans. | ||
| 4354 | D 1LE 1LC | ||
| 438 | 2: apply I1. | ||
| 4355 | E 1RF 0RE | ||
| 439 | es. | ||
| 4356 | F 1RA 0RB | ||
| 440 | - epose proof (pow2_ge n). | ||
| 4358 | units: D0 = 0000, D1 = 1000, P = 11000, S1 = 01000, SP = 011000, W = 111000 | ||
| 441 | split. | ||
| 4360 | arrival (one carry), for every left context l: | ||
| 442 | 1: solve_sigma_score. | ||
| 4361 | l B> w 0^inf -->* l <C w' 0^inf when Inc w w' | ||
| 443 | lia. | ||
| 4362 | Z B> 0 x --> <C 1 x (D0 -> D1, S1 -> P, SP -> W, blank -> D1) | ||
| 444 | Qed. | ||
| 4363 | D1 B> 1000 r --> 1111 B> r ~> 1111 <C r' --> <C 0000 r' | ||
| 4364 | P B> 11000 r --> 10111 B> r ~> 10111 <C r' --> <C 11000 r' | ||
| 4365 | W B> 111000 r --> 100111 B> r ~> --> 000111 B> r1 ~> --> 101111 B> r2 ~> | ||
| 4366 | --> <C 110000 r3 (W r --> P shift(inc^3 r)) | ||
| 4368 | left records 0^inf <q G U 0^inf, q G (8 types, cycle XC XD XE YC YD YE ZD ZE): | ||
| 4369 | XC C 111111 0000 11 0000 11 000 XD D 1111111 0000 11 0000 11 000 | ||
| 4370 | XE E 11111111 0000 11 0000 11 000 (3 W uses, F = W W P SP) | ||
| 4371 | YC C 1101111 0000 11 000 YD D 11101111 0000 11 000 | ||
| 4372 | YE E 111101111 0000 11 000 (12 W uses, F = W P W P P SP P P P P SP) | ||
| 4373 | ZD D 11111 0000 11 000 111 000 ZE E 111111 0000 11 000 111 000 (2 W uses, F = P SP) | ||
| 4374 | window: q G U -->+ q' G' F Phi_k(U), Phi = pop o inc^3 | ||
| 4376 | c0 -->* XC record with U0 = P SP P W P^3 SP P^4 W P^7 W P^11 W P^10 D0 D0 D1^4 (203,465 steps) | ||
| 4378 | closed zone system (Z, D, j): feed D + p(j mod 8) carries, p = 47 48 48 47 48 47 48 47, | ||
| 4379 | drop leading P (+3 carries each), stop at the least fixed point, absorption shift; | ||
| 4380 | from Z1 = S1 D0 D1 D1 D1 D0 D1, D = 0, j = 1 it reaches C(0) = S1 D0 D1^5, D = 16, j = 17. | ||
| 4381 | canonical states C(b) = S1 D0 D1^4 bin(b+1), D = 32b + 16, j = 32b + 17. | ||
| 4383 | zone engine (cut: X below, Y above; every shift lands in X): | ||
| 4384 | XN t X e X' t carries on X ++ Y give X' ++ Y' whenever e carries on Y give Y' | ||
| 4385 | cutstep the first T0 carries act on X alone (all drops happen there), | ||
| 4386 | the rest is counter arithmetic on X, the absorption shift lands in X | ||
| 4387 | family (X, y, ay, D, j, aD) stands for zone X ++ bin(y + ay u), | ||
| 4388 | D + aD u, j + aD u, for every u >= 0; one run covers every u | ||
| 4390 | proved by family runs (vm_compute): | ||
| 4391 | small classes nu2(b+2) = k <= 40: 327 direct runs + 328 families (o mod 16) | ||
| 4392 | endgame value form at off_end(k), nu2(k+9) <= 10, every U >= 1: | ||
| 4393 | 4,094 families (k mod 2^12), cut 12 | ||
| 4394 | nested range value form at off_end(k), k + 9 = s 2^v, 11 <= v <= 50: | ||
| 4395 | 80 families (s mod 4), cut v + 2 | ||
| 4397 | value forms VF(k, Om, off): digits of mu Om + w(off) - 3 2^(L-1), heads below digit 3, | ||
| 4398 | marker P at digit L = k + lam - off; j = Om - 64 + off, D = j - d | ||
| 4399 | descent step VF(off) --> VF(off + 1) for every Om = 0 mod 256, c >= 4096, L >= 5: | ||
| 4400 | the first 4096 carries on the low 8 digits, then counter arithmetic on | ||
| 4401 | residues; classes: 12 entry offsets (level 1, off 20..31) and | ||
| 4402 | off mod 256 x (L = 5, 6, 7, 8 or L >= 9) on the phase table | ||
| 4403 | VF1 level 1, k >= 41: VF(k, o 2^(k+5), 20) -->* VF at off_end(k) | ||
| 4404 | VF2 level 2, v >= 12, S >= 2: VF(v - 10, S 2^v, 17) -->* VF at off_end(v - 10) | ||
| 4406 | entry (b + 2 = (2q+1) 2^k, k >= 41) and plant (n = v - 3, S = 2Q + 1), by hand: | ||
| 4407 | off 17 S1 D0 D1^(k+4) D0 bin(q) off' 12 S1 P P D0 D0 D0 P [2^n-3]_n bin(2Q) | ||
| 4408 | off 18 D0^(k+6) S1 bin(q) off' 13 D0 D0 D0 SP [2^n-3]_n bin(4Q+1) | ||
| 4409 | off 19 S1 D0^(k+4) D1 s1w(q) off' 14 D0 S1 D0 P [2^n-3]_n D0 P bin(2Q-1) | ||
| 4410 | off 20 D0 S1 D0^(k+2) D1 P bin(4q) off' 15 S1 P D0 P [2^n-5]_n D0 P bin(4Q) | ||
| 4411 | off' 16 S1 P [2^n-6]_n D0 P bin(8Q+2) | ||
| 4412 | off' 17 S1 [2^(n-1)-3]_(n-1) D0 P bin(16Q+6) | ||
| 4413 | E(K): nu2(K+9) <= 50 by family runs; otherwise plant, VF2 and E(nu2(K+9) - 10) | ||
| 4415 | conveyor (positions in the U0 frame + 1, wall w: birth index b_w, state s_w, H_w): | ||
| 4416 | wall w after R carries: position b_w + (R + s_w)/2, W iff R + s_w odd, | ||
| 4417 | the wall above it has received H_w' + 3 (R + s_w)/2 carries | ||
| 4418 | Lemma T p(J mod 8) = 43 - 3 b_J + 2 b_(J-1) + s_(J-1) + H_(J-1) | ||
| 4419 | top wall absorbed <=> zone count reaches the least fixed point of the closed system | ||
| 4420 | record pops through the youngest wall, then the new walls F with R = 0 | ||
| 4421 | ``` | ||
| 4422 | *) | ||
3Proof outlineCheck: the new items (green) carry the argument; the names read like the proof.md rules.
416 items in 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v (4422 lines): 261 Lemma, 99 Definition, 29 Fixpoint, 15 Theorem, 10 Inductive, 2 Record. Tags against the template: identical = same name and same text once each file's own TM string is <TM> (marked "except the TM string" when that is the only difference); adapted = same name, different text; new = no item of that name in the template part.
| # | kind | name | statement (no proof body) | line | vs template |
|---|---|---|---|---|---|
| 1 | Definition | tm | Definition tm := Eval compute in (TM_from_str "1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB"). | L59 | identicalexcept the TM string |
| 2 | Definition | ArrS | Definition ArrS (r r' : side) : Prop := forall l, l {{B}}> r -->* l <{{C}} r'. | L70 | new |
| 3 | Lemma | arr_Z | Lemma arr_Z r : ArrS (0 >> r) (1 >> r). | L73 | new |
| 4 | Lemma | arr_D1 | Lemma arr_D1 r r' : ArrS r r' -> ArrS ([1;0;0;0] *> r) ([0;0;0;0] *> r'). | L77 | new |
| 5 | Lemma | arr_P | Lemma arr_P r r' : ArrS r r' -> ArrS ([1;1;0;0;0] *> r) ([1;1;0;0;0] *> r'). | L84 | new |
| 6 | Lemma | arr_W | Lemma arr_W r r1 r2 r3 : ArrS r r1 -> ArrS r1 r2 -> ArrS r2 r3 -> ArrS ([1;1;1;0;0;0] *> r) ([1;1;0;0;0;0] *> r3). | L92 | new |
| 7 | Inductive | unt | Inductive unt := uD0 | uD1 | uP | uS1 | uSP | uW. | L106 | new |
| 8 | Definition | ucells | Definition ucells (u : unt) : list Sym := match u with | uD0 => [0;0;0;0] | uD1 => [1;0;0;0] | uP => [1;1;0;0;0] | uS1 => [0;1;0;0;0] … +3 lines | L108 | new |
| 9 | Fixpoint | enc | Fixpoint enc (w : list unt) : list Sym := match w with | [] => [] | u :: w' => ucells u ++ enc w' end. | L118 | new |
| 10 | Definition | Rs | Definition Rs (w : list unt) : side := enc w *> const 0. | L124 | new |
| 11 | Lemma | Rs_cons | Lemma Rs_cons u w : Rs (u :: w) = ucells u *> Rs w. | L126 | new |
| 12 | Lemma | enc_app | Lemma enc_app a b : enc (a ++ b) = enc a ++ enc b. | L129 | new |
| 13 | Lemma | Rs_app | Lemma Rs_app a b : Rs (a ++ b) = enc a *> Rs b. | L132 | new |
| 14 | Fixpoint | shift | Fixpoint shift (w : list unt) : option (list unt) :=
match w with
| [] => Some []
| uD0 :: w' =>
match shift w' with
| Some w'' => Some (uD0 :: w'')
… +6 lines | L138 | new |
| 15 | Lemma | shift_spec | Lemma shift_spec w w' : shift w = Some w' -> 0 >> Rs w = Rs w'. | L151 | new |
| 16 | Inductive | Inc | Inductive Inc : list unt -> list unt -> Prop := | Inc_nil : Inc [] [uD1] | Inc_D0 w : Inc (uD0 :: w) (uD1 :: w) | Inc_S1 w : Inc (uS1 :: w) (uP :: w) | Inc_SP w : Inc (uSP :: w) (uW :: w) | Inc_D1 w w' : Inc w w' -> Inc (uD1 :: w) (uD0 :: w') … +3 lines | L163 | new |
| 17 | Theorem | inc_arr | Theorem inc_arr w w' : Inc w w' -> ArrS (Rs w) (Rs w'). | L174 | new |
| 18 | Lemma | Inc_det | Lemma Inc_det w a b : Inc w a -> Inc w b -> a = b. | L191 | new |
| 19 | Definition | Inc3Pop | Definition Inc3Pop (U U' : list unt) : Prop := exists a b, Inc U a /\ Inc a b /\ Inc b (uP :: U'). | L203 | new |
| 20 | Fixpoint | Pops | Fixpoint Pops (k : nat) (U U' : list unt) : Prop := match k with | O => U = U' | S k' => exists U1, Inc3Pop U U1 /\ Pops k' U1 U' end. | L206 | new |
| 21 | Definition | lcfg | Definition lcfg : Type := (list Sym * Sym * list Sym * Q)%type. | L219 | new |
| 22 | Definition | lc | Definition lc (X : side) (c : lcfg) : Q * tape := match c with (l, m, r, q) => (q, (l *> const 0, m, r *> X)) end. | L221 | new |
| 23 | Definition | lstep | Definition lstep (c : lcfg) : option (lcfg * bool) :=
match c with
| (l, m, r, q) =>
match tm (q, m) with
| None => None
| Some (s, L, q') =>
… +11 lines | L225 | new |
| 24 | Lemma | lstep_spec | Lemma lstep_spec X c c' b : lstep c = Some (c', b) -> lc X c --> lc X c'. | L243 | new |
| 25 | Definition | wready | Definition wready (c : lcfg) : bool := match c with | (_, S1, S1 :: S1 :: S0 :: S0 :: S0 :: [], B) => true | _ => false end. | L256 | new |
| 26 | Definition | wpop | Definition wpop (c : lcfg) : lcfg :=
match c with
| (l, _, _, _) =>
match l with
| [] => ([], 0, [1;1;0;0;0;0;1;1;0;0;0], C)
| x :: l' => (l', x, [1;1;0;0;0;0;1;1;0;0;0], C)
… +2 lines | L262 | new |
| 27 | Lemma | wpop_spec | Lemma wpop_spec c U U' : wready c = true -> Inc3Pop U U' -> lc (Rs U) c -->* lc (Rs U') (wpop c). | L271 | new |
| 28 | Fixpoint | wrun | Fixpoint wrun (fuel : nat) (c : lcfg) : option (lcfg * nat) :=
match fuel with
| O => None
| S f =>
if wready c then
match wrun f (wpop c) with
… +10 lines | L285 | new |
| 29 | Lemma | wrun_spec | Lemma wrun_spec f c c' k : wrun f c = Some (c', k) -> forall U U', Pops k U U' -> lc (Rs U) c -->+ lc (Rs U') c'. | L302 | new |
| 30 | Inductive | rt | Inductive rt := XC | XD | XE | YC | YD | YE | ZD | ZE. | L325 | new |
| 31 | Definition | rq | Definition rq (t : rt) : Q := match t with | XC | YC => C | XD | YD | ZD => D | XE | YE | ZE => E end. | L327 | new |
| 32 | Definition | rg | Definition rg (t : rt) : list Sym := match t with | XC => [1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0] | XD => [1;1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0] | XE => [1;1;1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0] | YC => [1;1;0;1;1;1;1; 0;0;0;0; 1;1; 0;0;0] … +5 lines | L335 | new |
| 33 | Definition | rnext | Definition rnext (t : rt) : rt := match t with | XC => XD | XD => XE | XE => YC | YC => YD | YD => YE | YE => ZD | ZD => ZE | ZE => XC end. | L347 | new |
| 34 | Definition | rk | Definition rk (t : rt) : nat := match t with XE => 3 | YE => 12 | ZE => 2 | _ => 0 end. | L354 | new |
| 35 | Definition | rF | Definition rF (t : rt) : list unt := match t with | XE => [uW; uW; uP; uSP] | YE => [uW; uP; uW; uP; uP; uSP; uP; uP; uP; uP; uSP] | ZE => [uP; uSP] | _ => [] … +1 lines | L358 | new |
| 36 | Definition | rcfg | Definition rcfg (t : rt) (U : list unt) : Q * tape :=
const 0 <{{rq t}} rg t *> Rs U. | L367 | new |
| 37 | Lemma | window_gen | Lemma window_gen t U U' : wrun 4000 ([], 0, rg t, rq t) = Some (([], 0, rg (rnext t) ++ enc (rF t), rq (rnext t)), rk t) -> Pops (rk t) U U' -> rcfg t U -->+ rcfg (rnext t) (rF t ++ U'). | L370 | new |
| 38 | Lemma | window | Lemma window t U U' : Pops (rk t) U U' -> rcfg t U -->+ rcfg (rnext t) (rF t ++ U'). | L380 | new |
| 39 | Definition | U0 | Definition U0 : list unt := [uP; uSP; uP; uW; uP; uP; uP; uSP; uP; uP; uP; uP; uW; uP; uP; uP; uP; uP; uP; uP; uW; uP; uP; uP; uP; uP; uP; uP; uP; uP; uP; uP; uW; uP; uP; uP; uP; uP; uP; uP; uP; uP; uP; uD0; uD0; uD1; uD1; uD1; uD1]. | L389 | new |
| 40 | Lemma | init | Lemma init : c0 -->* rcfg XC U0. | L396 | new |
| 41 | Inductive | Reach | Inductive Reach : rt -> list unt -> Prop := | Reach0 : Reach XC U0 | ReachS t U U' : Reach t U -> Pops (rk t) U U' -> Reach (rnext t) (rF t ++ U'). | L408 | new |
| 42 | Definition | AbsDefined | Definition AbsDefined : Prop := forall t U, Reach t U -> exists U', Pops (rk t) U U'. | L412 | new |
| 43 | Lemma | nonhalt_of_abs | Lemma nonhalt_of_abs : AbsDefined -> ~ halts tm c0. | L414 | new |
| 44 | Inductive | IncN | Inductive IncN : nat -> list unt -> list unt -> Prop := | IncN_0 w : IncN 0 w w | IncN_S n w w1 w2 : Inc w w1 -> IncN n w1 w2 -> IncN (S n) w w2. | L432 | new |
| 45 | Lemma | IncN_1 | Lemma IncN_1 w w' : Inc w w' -> IncN 1 w w'. | L436 | new |
| 46 | Lemma | IncN_1_inv | Lemma IncN_1_inv w w' : IncN 1 w w' -> Inc w w'. | L439 | new |
| 47 | Lemma | IncN_add | Lemma IncN_add a b w w1 w2 : IncN a w w1 -> IncN b w1 w2 -> IncN (a + b) w w2. | L442 | new |
| 48 | Lemma | IncN_split | Lemma IncN_split a b w w2 : IncN (a + b) w w2 -> exists w1, IncN a w w1 /\ IncN b w1 w2. | L445 | new |
| 49 | Lemma | IncN_det | Lemma IncN_det n w a b : IncN n w a -> IncN n w b -> a = b. | L453 | new |
| 50 | Lemma | IncN_snoc | Lemma IncN_snoc n w w1 w2 : IncN n w w1 -> Inc w1 w2 -> IncN (S n) w w2. | L460 | new |
| 51 | Lemma | IncN_P | Lemma IncN_P n w w' : IncN n w w' -> IncN n (uP :: w) (uP :: w'). | L467 | new |
| 52 | Lemma | IncN_P_inv | Lemma IncN_P_inv n w x : IncN n (uP :: w) x -> exists w', x = uP :: w' /\ IncN n w w'. | L470 | new |
| 53 | Fixpoint | Ps | Fixpoint Ps (a : nat) : list unt := match a with O => [] | S a' => uP :: Ps a' end. | L479 | new |
| 54 | Lemma | IncN_Ps | Lemma IncN_Ps a n w w' : IncN n w w' -> IncN n (Ps a ++ w) (Ps a ++ w'). | L481 | new |
| 55 | Definition | dig | Definition dig (b : nat) : unt := if Nat.eqb (Nat.modulo b 2) O then uD0 else uD1. | L485 | new |
| 56 | Definition | dval | Definition dval (u : unt) : nat := match u with uD1 => 1 | _ => 0 end. | L486 | new |
| 57 | Definition | isdig | Definition isdig (u : unt) : bool := match u with uD0 | uD1 => true | _ => false end. | L487 | new |
| 58 | Lemma | IncN_digit | Lemma IncN_digit t u w w' : isdig u = true -> IncN ((dval u + t) / 2) w w' -> IncN t (u :: w) (dig (dval u + t) :: w'). | L489 | new |
| 59 | Definition | wallu | Definition wallu (b : bool) : unt := if b then uW else uSP. | L529 | new |
| 60 | Lemma | Inc_SP_W | Lemma Inc_SP_W r : Inc (uSP :: r) (uW :: r). | L531 | new |
| 61 | Lemma | Inc_W_fire | Lemma Inc_W_fire r r' : Inc3Pop r r' -> Inc (uW :: r) (uP :: uSP :: r'). | L535 | new |
| 62 | Lemma | Pops_add | Lemma Pops_add a b U U1 U2 : Pops a U U1 -> Pops b U1 U2 -> Pops (a + b) U U2. | L540 | new |
| 63 | Lemma | Pops_split | Lemma Pops_split a b U U2 : Pops (a + b) U U2 -> exists U1, Pops a U U1 /\ Pops b U1 U2. | L547 | new |
| 64 | Lemma | wall_feed | Lemma wall_feed t (b : bool) r r' : Pops ((t + Nat.b2n b) / 2) r r' -> IncN t (wallu b :: r) (Ps ((t + Nat.b2n b) / 2) ++ wallu (Nat.odd (t + Nat.b2n b)) :: r'). | L556 | new |
| 65 | Lemma | C1 | Lemma C1 u r x : In u [uP; uS1; uSP; uW] -> IncN 3 (u :: r) x -> exists x', x = uP :: x'. | L591 | new |
| 66 | Fixpoint | digits | Fixpoint digits (r v : nat) : list unt := match r with | O => [] | S r' => dig v :: digits r' (v / 2) end. | L606 | new |
| 67 | Lemma | dval_dig | Lemma dval_dig v : dval (dig v) = v mod 2. | L612 | new |
| 68 | Lemma | isdig_dig | Lemma isdig_dig v : isdig (dig v) = true. | L618 | new |
| 69 | Lemma | dig_mod | Lemma dig_mod v : dig (v mod 2) = dig v. | L621 | new |
| 70 | Lemma | IncN_digits | Lemma IncN_digits r v t rest rest' : IncN ((v mod 2 ^ r + t) / 2 ^ r) rest rest' -> IncN t (digits r v ++ rest) (digits r (v + t) ++ rest'). | L625 | new |
| 71 | Definition | notP | Definition notP (w : list unt) : Prop := match w with uP :: _ => False | _ => True end. | L653 | new |
| 72 | Definition | pj | Definition pj (j : nat) : nat := nth (j mod 8) [47; 48; 48; 47; 48; 47; 48; 47] 47. | L655 | new |
| 73 | Definition | cs_step | Definition cs_step (Z : list unt) (D j : nat) (Z' : list unt) (D' j' : nat) : Prop := exists m A Y, IncN m Z (Ps A ++ Y) /\ notP Y /\ m = D + pj j + 3 * A /\ (forall m' A' Y', m' < m -> IncN m' Z (Ps A' ++ Y') -> notP Y' -> m' <> D + pj j + 3 * A') /\ shift Y = Some Z' /\ D' = D + A /\ j' = S j. | L660 | new |
| 74 | Inductive | CSreach | Inductive CSreach : list unt -> nat -> nat -> Prop := | CS1 : CSreach [uS1; uD0; uD1; uD1; uD1; uD0; uD1] 0 1 | CSS Z D j Z' D' j' : CSreach Z D j -> cs_step Z D j Z' D' j' -> CSreach Z' D' j'. | L666 | new |
| 75 | Fixpoint | incf | Fixpoint incf (n : nat) (w : list unt) : option (list unt) :=
match n with
| O => None
| S n' =>
match w with
| [] => Some [uD1]
… +20 lines | L671 | new |
| 76 | Lemma | incf_sound | Lemma incf_sound n w w' : incf n w = Some w' -> Inc w w'. | L698 | new |
| 77 | Fixpoint | incNf | Fixpoint incNf (fuel k : nat) (w : list unt) : option (list unt) := match k with | O => Some w | S k' => match incf fuel w with Some x => incNf fuel k' x | None => None end end. | L716 | new |
| 78 | Lemma | incNf_sound | Lemma incNf_sound fuel k w w' : incNf fuel k w = Some w' -> IncN k w w'. | L722 | new |
| 79 | Fixpoint | splitP | Fixpoint splitP (w : list unt) : nat * list unt := match w with | uP :: w' => let (a, y) := splitP w' in (S a, y) | _ => (O, w) end. | L730 | new |
| 80 | Lemma | splitP_spec | Lemma splitP_spec w : let (a, y) := splitP w in w = Ps a ++ y /\ notP y. | L736 | new |
| 81 | Lemma | Ps_notP_inj | Lemma Ps_notP_inj a b x y : Ps a ++ x = Ps b ++ y -> notP x -> notP y -> a = b /\ x = y. | L743 | new |
| 82 | Lemma | IncN_Ps_inv | Lemma IncN_Ps_inv k a y x : IncN k (Ps a ++ y) x -> exists y', x = Ps a ++ y' /\ IncN k y y'. | L753 | new |
| 83 | Lemma | Ps_prefix_le | Lemma Ps_prefix_le a b y Y : Ps a ++ y = Ps b ++ Y -> notP Y -> a <= b. | L761 | new |
| 84 | Definition | NF | Definition NF (Z : list unt) (c m' : nat) : Prop := forall A' Y', IncN m' Z (Ps A' ++ Y') -> notP Y' -> m' <> c + 3 * A'. | L769 | new |
| 85 | Fixpoint | cs_loop | Fixpoint cs_loop (fuel cf c m : nat) (Zm : list unt) : option (nat * nat * list unt) :=
match fuel with
| O => None
| S f =>
let (a, y) := splitP Zm in
if Nat.eqb m (c + 3 * a) then Some (m, a, y)
… +6 lines | L772 | new |
| 86 | Lemma | cs_loop_sound | Lemma cs_loop_sound fuel cf c Z m Zm m2 A2 Y2 : cs_loop fuel cf c m Zm = Some (m2, A2, Y2) -> IncN m Z Zm -> (forall m', m' < m -> NF Z c m') -> (forall A Y, Zm = Ps A ++ Y -> notP Y -> m <= c + 3 * A) -> IncN m2 Z (Ps A2 ++ Y2) /\ notP Y2 /\ m2 = c + 3 * A2 /\ (forall m', m' < m2 -> NF Z c m'). | L785 | new |
| 87 | Definition | csf | Definition csf (fuel cf : nat) (s : list unt * nat * nat) : option (list unt * nat * nat) :=
let '(z, d, j) := s in
match incNf cf (d + pj j) z with
| None => None
| Some zc =>
match cs_loop fuel cf (d + pj j) (d + pj j) zc with
… +8 lines | L819 | new |
| 88 | Lemma | csf_sound | Lemma csf_sound fuel cf Z D j Z' D' j' : csf fuel cf (Z, D, j) = Some (Z', D', j') -> cs_step Z D j Z' D' j'. | L834 | new |
| 89 | Fixpoint | csiter | Fixpoint csiter (n : nat) (s : list unt * nat * nat) : option (list unt * nat * nat) := match n with | O => Some s | S n' => match csf 200 200 s with Some s' => csiter n' s' | None => None end end. | L849 | new |
| 90 | Lemma | csiter_reach | Lemma csiter_reach n Z D j Z' D' j' : CSreach Z D j -> csiter n (Z, D, j) = Some (Z', D', j') -> CSreach Z' D' j'. | L855 | new |
| 91 | Lemma | C0_reach | Lemma C0_reach : CSreach [uS1; uD0; uD1; uD1; uD1; uD1; uD1] 16 17. | L865 | new |
| 92 | Lemma | IncN_3_inv | Lemma IncN_3_inv w x : IncN 3 w x -> exists a b, Inc w a /\ Inc a b /\ Inc b x. | L875 | new |
| 93 | Lemma | Inc3Pop_of | Lemma Inc3Pop_of w x : IncN 3 w (uP :: x) -> Inc3Pop w x. | L884 | new |
| 94 | Lemma | IncN_of_Inc3Pop | Lemma IncN_of_Inc3Pop w x : Inc3Pop w x -> IncN 3 w (uP :: x). | L887 | new |
| 95 | Lemma | Inc3Pop_P | Lemma Inc3Pop_P y y3 : IncN 3 y y3 -> Inc3Pop (uP :: y) y3. | L894 | new |
| 96 | Lemma | Pops_Ps | Lemma Pops_Ps k a y y' : IncN (3 * k) y y' -> Pops k (Ps (k + a) ++ y) (Ps a ++ y'). | L897 | new |
| 97 | Lemma | Inc3Pop_wall | Lemma Inc3Pop_wall (b : bool) r r' : Pops ((3 + Nat.b2n b) / 2) r r' -> Inc3Pop (wallu b :: r) (Ps ((3 + Nat.b2n b) / 2 - 1) ++ wallu (Nat.odd (3 + Nat.b2n b)) :: r'). | L909 | new |
| 98 | Fixpoint | shiftX | Fixpoint shiftX (X : list unt) : option (list unt) :=
match X with
| [] => None
| uD0 :: X' =>
match shiftX X' with
| Some X'' => Some (uD0 :: X'')
… +6 lines | L926 | new |
| 99 | Lemma | shiftX_app | Lemma shiftX_app X X' Y : shiftX X = Some X' -> shift (X ++ Y) = Some (X' ++ Y). | L939 | new |
| 100 | Inductive | IncX | Inductive IncX : list unt -> nat -> list unt -> Prop := | IncX_nil : IncX [] 1 [] | IncX_D0 X : IncX (uD0 :: X) 0 (uD1 :: X) | IncX_S1 X : IncX (uS1 :: X) 0 (uP :: X) | IncX_SP X : IncX (uSP :: X) 0 (uW :: X) | IncX_D1 X e X' : IncX X e X' -> IncX (uD1 :: X) e (uD0 :: X') … +4 lines | L949 | new |
| 101 | Lemma | IncX_flow | Lemma IncX_flow X e X' : IncX X e X' -> forall Y Y', IncN e Y Y' -> Inc (X ++ Y) (X' ++ Y'). | L960 | new |
| 102 | Inductive | IncXN | Inductive IncXN : nat -> list unt -> nat -> list unt -> Prop := | IncXN_0 X : IncXN 0 X 0 X | IncXN_S n X e X1 e' X2 : IncX X e X1 -> IncXN n X1 e' X2 -> IncXN (S n) X (e + e') X2. | L981 | new |
| 103 | Lemma | IncXN_flow | Lemma IncXN_flow n X e X' : IncXN n X e X' -> forall Y Y', IncN e Y Y' -> IncN n (X ++ Y) (X' ++ Y'). | L985 | new |
| 104 | Fixpoint | incXf | Fixpoint incXf (n : nat) (X : list unt) : option (nat * list unt) :=
match n with
| O => None
| S n' =>
match X with
| [] => Some (1%nat, [])
… +24 lines | L997 | new |
| 105 | Lemma | incXf_sound | Lemma incXf_sound n X e X' : incXf n X = Some (e, X') -> IncX X e X'. | L1028 | new |
| 106 | Fixpoint | binp | Fixpoint binp (p : positive) : list unt := match p with | xH => [uD1] | xO p' => uD0 :: binp p' | xI p' => uD1 :: binp p' end. | L1052 | new |
| 107 | Definition | binN | Definition binN (n : N) : list unt := match n with N0 => [] | Npos p => binp p end. | L1059 | new |
| 108 | Definition | bin | Definition bin (v : nat) : list unt := binN (N.of_nat v). | L1061 | new |
| 109 | Definition | digN | Definition digN (n : N) : unt := match n with | N0 => uD0 | Npos xH => uD1 | Npos (xO _) => uD0 | Npos (xI _) => uD1 … +1 lines | L1063 | new |
| 110 | Lemma | dig_even | Lemma dig_even x : dig (2 * x) = uD0. | L1071 | new |
| 111 | Lemma | dig_odd | Lemma dig_odd x : dig (2 * x + 1) = uD1. | L1074 | new |
| 112 | Lemma | digN_dig | Lemma digN_dig n : digN n = dig (N.to_nat n). | L1077 | new |
| 113 | Lemma | Inc_binp | Lemma Inc_binp p : Inc (binp p) (binp (Pos.succ p)). | L1087 | new |
| 114 | Lemma | Inc_binN | Lemma Inc_binN n : Inc (binN n) (binN (N.succ n)). | L1095 | new |
| 115 | Lemma | IncN_binN | Lemma IncN_binN t n : IncN t (binN n) (binN (n + N.of_nat t)). | L1098 | new |
| 116 | Lemma | IncN_bin | Lemma IncN_bin t v : IncN t (bin v) (bin (v + t)). | L1106 | new |
| 117 | Lemma | binN_eq | Lemma binN_eq n : binN n = if N.eqb n 0 then [] else digN n :: binN (N.div2 n). | L1109 | new |
| 118 | Lemma | bin_eq | Lemma bin_eq v : bin v = if Nat.eqb v 0 then [] else dig v :: bin (v / 2). | L1112 | new |
| 119 | Lemma | bin_pos | Lemma bin_pos v : 0 < v -> bin v = dig v :: bin (v / 2). | L1120 | new |
| 120 | Lemma | bin_0 | Lemma bin_0 : bin 0 = []. | L1123 | new |
| 121 | Lemma | IncN_nil_bin | Lemma IncN_nil_bin t : IncN t [] (bin t). | L1126 | new |
| 122 | Lemma | dig_add_even | Lemma dig_add_even v s : dig (v + 2 * s) = dig v. | L1130 | new |
| 123 | Lemma | div2_add_even | Lemma div2_add_even v s : (v + 2 * s) / 2 = v / 2 + s. | L1133 | new |
| 124 | Lemma | digits_app_bin | Lemma digits_app_bin n x y : x < 2 ^ n -> 0 < y -> digits n x ++ bin y = bin (x + 2 ^ n * y). | L1136 | new |
| 125 | Lemma | bin_ones | Lemma bin_ones k q : bin (2 ^ k - 1 + 2 ^ (k + 1) * q) = repeat uD1 k ++ bin (2 * q). | L1149 | new |
| 126 | Fixpoint | allb | Fixpoint allb (f : unt -> bool) (w : list unt) : bool := match w with [] => true | u :: w' => f u && allb f w' end. | L1165 | new |
| 127 | Fixpoint | ndig | Fixpoint ndig (X : list unt) : nat := match X with [] => O | u :: X' => (if isdig u then 1 else 0) + ndig X' end. | L1168 | new |
| 128 | Fixpoint | val | Fixpoint val (X : list unt) : nat := match X with [] => O | u :: X' => if isdig u then dval u + 2 * val X' else val X' end. | L1171 | new |
| 129 | Lemma | digits_val | Lemma digits_val Xd : allb isdig Xd = true -> Xd = digits (length Xd) (val Xd). | L1174 | new |
| 130 | Lemma | val_lt | Lemma val_lt Xd : allb isdig Xd = true -> val Xd < 2 ^ length Xd. | L1188 | new |
| 131 | Definition | XN | Definition XN (t : nat) (X : list unt) (e : nat) (X' : list unt) : Prop := forall Y Y', IncN e Y Y' -> IncN t (X ++ Y) (X' ++ Y'). | L1201 | new |
| 132 | Lemma | XN_0 | Lemma XN_0 X : XN 0 X 0 X. | L1204 | new |
| 133 | Lemma | XN_nil | Lemma XN_nil t : XN t [] t []. | L1207 | new |
| 134 | Lemma | XN_add | Lemma XN_add a b X e1 X1 e2 X2 : XN a X e1 X1 -> XN b X1 e2 X2 -> XN (a + b) X (e1 + e2) X2. | L1210 | new |
| 135 | Lemma | XN_P | Lemma XN_P t X e X' : XN t X e X' -> XN t (uP :: X) e (uP :: X'). | L1216 | new |
| 136 | Lemma | XN_digit | Lemma XN_digit t u X e X' : isdig u = true -> XN ((dval u + t) / 2) X e X' -> XN t (u :: X) e (dig (dval u + t) :: X'). | L1219 | new |
| 137 | Lemma | XN_S1 | Lemma XN_S1 t X e X' : XN t X e X' -> XN (S t) (uS1 :: X) e (uP :: X'). | L1223 | new |
| 138 | Lemma | XN_SP | Lemma XN_SP t X e X' : XN t (uW :: X) e X' -> XN (S t) (uSP :: X) e X'. | L1226 | new |
| 139 | Lemma | XN_W | Lemma XN_W t X e1 X1 X2 e2 X3 : XN 3 X e1 X1 -> shiftX X1 = Some X2 -> XN t X2 e2 X3 -> XN (S t) (uW :: X) (e1 + e2) (uP :: X3). | L1229 | new |
| 140 | Fixpoint | xfeed | Fixpoint xfeed (f : nat) (t : N) (X : list unt) : option (list unt * N) := match f with | O => None | S f' => if N.eqb t 0 then Some (X, 0%N) else match X with … +24 lines | L1240 | new |
| 141 | Lemma | xfeed_sound | Lemma xfeed_sound f t X X' e : xfeed f t X = Some (X', e) -> XN (N.to_nat t) X (N.to_nat e) X'. | L1271 | new |
| 142 | Fixpoint | fill | Fixpoint fill (X : list unt) (v : nat) : list unt := match X with | [] => [] | u :: X' => if isdig u then dig v :: fill X' (v / 2) else u :: fill X' v end. | L1310 | new |
| 143 | Definition | cleanu | Definition cleanu (u : unt) : bool := match u with uD0 | uD1 | uP => true | _ => false end. | L1316 | new |
| 144 | Lemma | XN_clean | Lemma XN_clean X t : allb cleanu X = true -> XN t X ((val X + t) / 2 ^ ndig X) (fill X (val X + t)). | L1318 | new |
| 145 | Lemma | fill_mod | Lemma fill_mod X v s : fill X (v + 2 ^ ndig X * s) = fill X v. | L1353 | new |
| 146 | Lemma | div_mod_shift | Lemma div_mod_shift v n s : (v + 2 ^ n * s) / 2 ^ n = v / 2 ^ n + s. | L1363 | new |
| 147 | Definition | dhead | Definition dhead (w : list unt) : bool := match w with uD0 :: _ | uD1 :: _ => true | _ => false end. | L1370 | new |
| 148 | Lemma | Inc_dhead | Lemma Inc_dhead w w' : dhead w = true -> Inc w w' -> dhead w' = true. | L1372 | new |
| 149 | Lemma | IncN_dhead | Lemma IncN_dhead n w w' : dhead w = true -> IncN n w w' -> dhead w' = true. | L1375 | new |
| 150 | Lemma | dhead_app | Lemma dhead_app X Y : dhead X = true -> dhead (X ++ Y) = true. | L1378 | new |
| 151 | Lemma | dhead_notP | Lemma dhead_notP w : dhead w = true -> notP w. | L1381 | new |
| 152 | Lemma | cutstep | Lemma cutstep X Y T0 e1 A X1 c e2 X2 D j Z' Y' : XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true -> XN (c + 3 * A - T0) X1 e2 X2 -> T0 <= c -> c = D + pj j -> IncN (e1 + e2) Y Y' -> shift (X2 ++ Y') = Some Z' -> cs_step (X ++ Y) D j Z' (D + A) (S j). | L1390 | new |
| 153 | Record | fam | Record fam := mkF { fX : list unt; fy : N; fay : N; fD : N; fj : N; faD : N }. | L1426 | new |
| 154 | Definition | st | Definition st : Type := (list unt * nat * nat)%type. | L1428 | new |
| 155 | Definition | fz | Definition fz (F : fam) (u : nat) : st := (fX F ++ bin (N.to_nat (fy F) + N.to_nat (fay F) * u), N.to_nat (fD F) + N.to_nat (faD F) * u, N.to_nat (fj F) + N.to_nat (faD F) * u). | L1430 | new |
| 156 | Definition | CS | Definition CS (s s' : st) : Prop := cs_step (fst (fst s)) (snd (fst s)) (snd s) (fst (fst s')) (snd (fst s')) (snd s'). | L1435 | new |
| 157 | Inductive | CSplus | Inductive CSplus : st -> st -> Prop := | CSp1 s s' : CS s s' -> CSplus s s' | CSpS s s1 s' : CS s s1 -> CSplus s1 s' -> CSplus s s'. | L1438 | new |
| 158 | Lemma | CSplus_trans | Lemma CSplus_trans a b c : CSplus a b -> CSplus b c -> CSplus a c. | L1442 | new |
| 159 | Lemma | CS_j | Lemma CS_j s s' : CS s s' -> snd s' = S (snd s). | L1445 | new |
| 160 | Lemma | CSplus_j | Lemma CSplus_j a b : CSplus a b -> snd a < snd b. | L1451 | new |
| 161 | Definition | pjN | Definition pjN (j : N) : N := N.of_nat (pj (N.to_nat (j mod 8))). | L1454 | new |
| 162 | Lemma | pj_mod | Lemma pj_mod j : pj j = pj (j mod 8). | L1456 | new |
| 163 | Lemma | pjN_spec | Lemma pjN_spec j : N.to_nat (pjN j) = pj (N.to_nat j). | L1459 | new |
| 164 | Lemma | pj_add8 | Lemma pj_add8 j a : a mod 8 = O -> forall u, pj (j + a * u) = pj j. | L1462 | new |
| 165 | Fixpoint | valN | Fixpoint valN (X : list unt) : N := match X with | [] => 0%N | u :: X' => if isdig u then (N.of_nat (dval u) + 2 * valN X')%N else valN X' end. | L1469 | new |
| 166 | Lemma | valN_spec | Lemma valN_spec X : N.to_nat (valN X) = val X. | L1475 | new |
| 167 | Fixpoint | fillN | Fixpoint fillN (X : list unt) (v : N) : list unt := match X with | [] => [] | u :: X' => if isdig u then digN v :: fillN X' (N.div2 v) else u :: fillN X' v end. | L1482 | new |
| 168 | Lemma | fillN_spec | Lemma fillN_spec X v : fillN X v = fill X (N.to_nat v). | L1488 | new |
| 169 | Fixpoint | fnorm | Fixpoint fnorm (n : nat) (F : fam) : fam :=
match n with
| O => F
| S n' =>
if N.even (fay F) && N.ltb 0 (fy F) then
fnorm n' (mkF (fX F ++ [digN (fy F)]) (N.div2 (fy F)) (N.div2 (fay F)) (fD F) (fj F) (faD F))
… +2 lines | L1495 | new |
| 170 | Lemma | fnorm_spec | Lemma fnorm_spec n F u : fz (fnorm n F) u = fz F u. | L1504 | new |
| 171 | Definition | n3 | Definition n3 (a : nat) : N := N.of_nat (3 * a). | L1523 | new |
| 172 | Lemma | n3_spec | Lemma n3_spec a : N.to_nat (n3 a) = 3 * a. | L1525 | new |
| 173 | Definition | phase2 | Definition phase2 (F : fam) (X1 : list unt) (a : nat) : option (list unt * N * N) := let nd := N.of_nat (ndig X1) in if allb cleanu X1 then let v := (valN X1 + n3 a)%N in Some (fillN X1 v, (v / 2 ^ nd)%N, (fay F + faD F / 2 ^ nd)%N) else if N.eqb (faD F) 0 then … +5 lines | L1528 | new |
| 174 | Definition | fstep | Definition fstep (R : nat) (F : fam) : option fam := if negb (N.eqb (faD F mod 8) 0) then None else match xfeed 4000 (fD F + pjN (fj F)) (fX F) with | None => None | Some (Xt, e1) => let (a, X1) := splitP Xt in … +18 lines | L1540 | new |
| 175 | Lemma | phase2_sound | Lemma phase2_sound F X1 a X2 e2 ay2 u : phase2 F X1 a = Some (X2, e2, ay2) -> N.to_nat (faD F) mod 2 ^ ndig X1 = O -> XN (3 * a + N.to_nat (faD F) * u) X1 (N.to_nat e2 + (N.to_nat ay2 - N.to_nat (fay F)) * u) X2 /\ N.to_nat (fay F) <= N.to_nat ay2. | L1565 | new |
| 176 | Lemma | if_negb_true | Lemma if_negb_true A (x y : A) : (if negb true then x else y) = y. | L1600 | new |
| 177 | Lemma | fstep_sound | Lemma fstep_sound R F F' : fstep R F = Some F' -> forall u, CS (fz F u) (fz F' u). | L1605 | new |
| 178 | Definition | Cst | Definition Cst (b : nat) : st := ([uS1; uD0; uD1; uD1; uD1; uD1] ++ bin (S b), 32 * b + 16, 32 * b + 17). | L1673 | new |
| 179 | Definition | unt_eq_dec | Definition unt_eq_dec (a b : unt) : {a = b} + {a <> b}. | L1675 | new |
| 180 | Definition | lsteqb | Definition lsteqb (l1 l2 : list unt) : bool := if list_eq_dec unt_eq_dec l1 l2 then true else false. | L1678 | new |
| 181 | Definition | canonb | Definition canonb (F : fam) : bool := match fX F with | uS1 :: uD0 :: uD1 :: uD1 :: uD1 :: uD1 :: Xd => allb isdig Xd && N.leb 17 (fj F) && N.eqb ((fj F - 17) mod 32) 0 && N.eqb (fD F + 1) (fj F) && N.eqb (faD F mod 32) 0 && (if N.eqb (fay F) 0 && N.eqb (faD F) 0 then lsteqb (Xd ++ binN (fy F)) (binN ((fj F - 17) / 32 + 1)) … +5 lines | L1680 | new |
| 182 | Lemma | canonb_sound | Lemma canonb_sound F : canonb F = true -> exists b0 g, forall u, fz F u = Cst (b0 + g * u). | L1692 | new |
| 183 | Fixpoint | frun | Fixpoint frun (n R : nat) (F : fam) : bool :=
match n with
| O => false
| S n' =>
match fstep R F with
| None => false
… +3 lines | L1746 | new |
| 184 | Lemma | frun_sound | Lemma frun_sound n R F : frun n R F = true -> forall u, exists b', CSplus (fz F u) (Cst b'). | L1756 | new |
| 185 | Definition | Zcl | Definition Zcl (b : N) : list unt := [uS1; uD0; uD1; uD1; uD1; uD1] ++ binN (b + 1). | L1770 | new |
| 186 | Definition | sc_direct | Definition sc_direct (k o0 : nat) : fam := let b := (N.of_nat o0 * 2 ^ N.of_nat k - 2)%N in mkF (Zcl b) 0 0 (32 * b + 16) (32 * b + 17) 0. | L1772 | new |
| 187 | Definition | sc_fam | Definition sc_fam (k o0 : nat) : fam :=
let j0 := (32 * ((N.of_nat o0 + 16) * 2 ^ N.of_nat k - 2) + 17)%N in
mkF ([uS1; uD0] ++ repeat uD1 (k + 4) ++ uD0 :: digits 3 ((o0 - 1) / 2)) 1 1 (j0 - 1) j0
(2 ^ N.of_nat (k + 9)). | L1776 | new |
| 188 | Definition | sc_ok | Definition sc_ok (k o0 : nat) : bool := (if Nat.eqb k O && Nat.eqb o0 1%nat then true else frun 100 10000 (sc_direct k o0)) && frun 100 (k + 9) (sc_fam k o0). | L1781 | new |
| 189 | Fixpoint | upto | Fixpoint upto (n : nat) : list nat := match n with O => [] | S n' => upto n' ++ [n'] end. | L1785 | new |
| 190 | Lemma | upto_In | Lemma upto_In k n : k < n -> In k (upto n). | L1787 | new |
| 191 | Definition | odds16 | Definition odds16 : list nat := [1%nat; 3; 5; 7; 9; 11; 13; 15]. | L1793 | new |
| 192 | Lemma | sc_all | Lemma sc_all : forallb (fun k => forallb (fun o0 => sc_ok k o0) odds16) (upto 41) = true. | L1795 | new |
| 193 | Lemma | sc_ok_of | Lemma sc_ok_of k o0 : k <= 40 -> In o0 odds16 -> sc_ok k o0 = true. | L1798 | new |
| 194 | Lemma | odd_decomp | Lemma odd_decomp n : 0 < n -> exists k o, n = o * 2 ^ k /\ Nat.odd o = true. | L1805 | new |
| 195 | Lemma | Cst_zone | Lemma Cst_zone k q b : b + 2 = (2 * q + 1) * 2 ^ k -> fst (fst (Cst b)) = [uS1; uD0; uD1; uD1; uD1; uD1] ++ repeat uD1 k ++ bin (2 * q). | L1816 | new |
| 196 | Lemma | odd_mod16 | Lemma odd_mod16 o : Nat.odd o = true -> In (o mod 16) odds16. | L1823 | new |
| 197 | Lemma | odds16_half | Lemma odds16_half r : In r odds16 -> r = 2 * ((r - 1) / 2) + 1. | L1836 | new |
| 198 | Theorem | small_classes | Theorem small_classes b k o : b + 2 = o * 2 ^ k -> Nat.odd o = true -> k <= 40 -> exists b', CSplus (Cst b) (Cst b'). | L1839 | new |
| 199 | Fixpoint | vfl | Fixpoint vfl (hs : list (list unt)) (L V : nat) : list unt := match L with | O => uP :: bin V | S L' => hd [] hs ++ dig V :: vfl (tl hs) L' (V / 2) end. | L1910 | new |
| 200 | Fixpoint | vlow | Fixpoint vlow (hs : list (list unt)) (L R V : nat) : list unt :=
match L with
| O => uP :: digits R V
| S L' =>
match R with
| O => []
… +3 lines | L1916 | new |
| 201 | Lemma | digits_mod | Lemma digits_mod R V s : digits R (V + 2 ^ R * s) = digits R V. | L1926 | new |
| 202 | Lemma | digits_bin_split | Lemma digits_bin_split R V : 2 ^ R <= V -> bin V = digits R V ++ bin (V / 2 ^ R). | L1934 | new |
| 203 | Lemma | vfl_split | Lemma vfl_split hs L R V : L < R -> 2 ^ R <= V -> vfl hs L V = vlow hs L R V ++ bin (V / 2 ^ R). | L1946 | new |
| 204 | Lemma | vlow_mod | Lemma vlow_mod hs L R V s : vlow hs L R (V + 2 ^ R * s) = vlow hs L R V. | L1955 | new |
| 205 | Record | vrow | Record vrow := mkV { vh : list (list unt); vlam : nat; vmu : nat; val_ : nat; vwp : nat; vwn : nat; vd : nat }. | L1965 | new |
| 206 | Definition | phrows | Definition phrows : list vrow := [ mkV [[uS1]] 24 1 1 0 20 2; mkV [[uS1]] 24 1 1 0 20 2; mkV [[]; [uS1]] 24 1 1 0 20 2; mkV [[]; [uSP]] 25 2 2 0 42 3; mkV [[uS1; uP; uP]] 24 1 1 0 24 4; … +3 lines | L1967 | new |
| 207 | Definition | phrow | Definition phrow (phi : nat) : vrow := nth phi phrows (mkV [] 24 1 1 0 24 4). | L1977 | new |
| 208 | Definition | vfz | Definition vfz (r : vrow) (k Om off : nat) : st := let L := k + vlam r - off in let V := vmu r * Om + val_ r * off + vwp r - (vwn r + 3 * 2 ^ (L - 1)) in let j := Om + off - 64 in (vfl (vh r) L V, j - vd r, j). | L1979 | new |
| 209 | Definition | off_end | Definition off_end (k : nat) : nat := if Nat.eqb ((k + 20) mod 8) 3 then k + 21 else k + 20. | L1985 | new |
| 210 | Definition | VFe | Definition VFe (k Om : nat) : st := vfz (phrow (off_end k mod 8)) k Om (off_end k). | L1987 | new |
| 211 | Fixpoint | digitsN | Fixpoint digitsN (r : nat) (v : N) : list unt := match r with O => [] | S r' => digN v :: digitsN r' (N.div2 v) end. | L1990 | new |
| 212 | Lemma | digitsN_spec | Lemma digitsN_spec r v : digitsN r v = digits r (N.to_nat v). | L1993 | new |
| 213 | Fixpoint | vlowN | Fixpoint vlowN (hs : list (list unt)) (L R : nat) (V : N) : list unt :=
match L with
| O => uP :: digitsN R V
| S L' =>
match R with
| O => []
… +3 lines | L1999 | new |
| 214 | Lemma | vlowN_spec | Lemma vlowN_spec hs L R V : vlowN hs L R V = vlow hs L R (N.to_nat V). | L2009 | new |
| 215 | Definition | off_endN | Definition off_endN (k : N) : N := if N.eqb ((k + 20) mod 8) 3 then (k + 21)%N else (k + 20)%N. | L2017 | new |
| 216 | Definition | egr | Definition egr (k0 : N) : vrow := phrow (N.to_nat (off_endN k0 mod 8)). | L2019 | new |
| 217 | Definition | egL | Definition egL (k0 : N) : nat := N.to_nat (k0 + N.of_nat (vlam (egr k0)) - off_endN k0). | L2021 | new |
| 218 | Definition | egV | Definition egV (k0 : N) (Om0 : N) : N := (N.of_nat (vmu (egr k0)) * Om0 + N.of_nat (val_ (egr k0)) * off_endN k0 + N.of_nat (vwp (egr k0)) - N.of_nat (vwn (egr k0) + 3 * 2 ^ (egL k0 - 1)))%N. | L2023 | new |
| 219 | Definition | egF | Definition egF (k0 : N) (Om0 : N) (R : nat) : fam :=
let j0 := (Om0 + off_endN k0 - 64)%N in
mkF (vlowN (vh (egr k0)) (egL k0) R (egV k0 Om0)) (egV k0 Om0 / 2 ^ N.of_nat R) 1
(j0 - N.of_nat (vd (egr k0))) j0 (2 ^ N.of_nat R). | L2027 | new |
| 220 | Definition | egok | Definition egok (k0 : N) (Om0 : N) (R : nat) : bool := Nat.ltb (egL k0) R && N.leb (2 ^ N.of_nat R) (egV k0 Om0) && N.leb 64 Om0 && Nat.eqb (vmu (egr k0)) 1 && Nat.eqb (val_ (egr k0)) 1 && Nat.leb (vd (egr k0)) 20 && frun 120 R (egF k0 Om0 R). | L2032 | new |
| 221 | Definition | egbase | Definition egbase (kap : nat) : N := N.of_nat (if Nat.ltb kap 41 then kap + 4096 else kap). | L2037 | new |
| 222 | Definition | eg_ok | Definition eg_ok (kap : nat) : bool := Nat.eqb ((kap + 9) mod 2048) O || egok (egbase kap) (2 ^ 46) 12. | L2039 | new |
| 223 | Lemma | eg_all | Lemma eg_all : forallb eg_ok (upto 4096) = true. | L2042 | new |
| 224 | Definition | ns_ok | Definition ns_ok (v : nat) (s0 : N) : bool := egok (s0 * 2 ^ N.of_nat v - 9) (2 ^ N.of_nat (v + 10)) (v + 2). | L2045 | new |
| 225 | Lemma | ns_all | Lemma ns_all : forallb (fun v => ns_ok (v + 11) 1 && ns_ok (v + 11) 3) (upto 40) = true. | L2048 | new |
| 226 | Lemma | off_endN_spec | Lemma off_endN_spec k : N.to_nat (off_endN k) = off_end (N.to_nat k). | L2051 | new |
| 227 | Lemma | mod8_of | Lemma mod8_of k k0 R : 3 <= R -> k0 <= k -> (k - k0) mod 2 ^ R = O -> k mod 8 = k0 mod 8. | L2063 | new |
| 228 | Lemma | off_end_shift | Lemma off_end_shift k k0 : k mod 8 = k0 mod 8 -> off_end k = k + (off_end k0 - k0) /\ k0 + 20 <= off_end k0 /\ off_end k mod 8 = off_end k0 mod 8. | L2071 | new |
| 229 | Lemma | eg_family | Lemma eg_family k0 Om0 R k Om : egok k0 Om0 R = true -> 3 <= R -> N.to_nat k0 <= k -> (k - N.to_nat k0) mod 2 ^ R = O -> N.to_nat Om0 <= Om -> (Om - N.to_nat Om0) mod 2 ^ R = O -> exists b', CSplus (VFe k Om) (Cst b'). | L2082 | new |
| 230 | Lemma | pow_le_mono2 | Lemma pow_le_mono2 a b : a <= b -> 2 ^ a <= 2 ^ b. | L2137 | new |
| 231 | Lemma | pow_mod_sub | Lemma pow_mod_sub a b c U : c <= a -> c <= b -> 2 ^ b <= U * 2 ^ a -> (U * 2 ^ a - 2 ^ b) mod 2 ^ c = O. | L2140 | new |
| 232 | Theorem | endgame | Theorem endgame k U : 41 <= k -> (k + 9) mod 2048 <> O -> 1 <= U -> exists b', CSplus (VFe k (U * 2 ^ (k + 5))) (Cst b'). | L2151 | new |
| 233 | Theorem | nested | Theorem nested k U s v : k + 9 = s * 2 ^ v -> Nat.odd s = true -> 11 <= v <= 50 -> 1 <= U -> exists b', CSplus (VFe k (U * 2 ^ (k + 5))) (Cst b'). | L2182 | new |
| 234 | Lemma | odd_not_mod2048 | Lemma odd_not_mod2048 s v : Nat.odd s = true -> v <= 10 -> (s * 2 ^ v) mod 2048 <> O. | L2233 | new |
| 235 | Theorem | E_low | Theorem E_low K U s v : 41 <= K -> K + 9 = s * 2 ^ v -> Nat.odd s = true -> v <= 50 -> 1 <= U -> exists b', CSplus (VFe K (U * 2 ^ (K + 5))) (Cst b'). | L2247 | new |
| 236 | Definition | ctr | Definition ctr (Yc : nat -> list unt) : Prop := forall n e, IncN e (Yc n) (Yc (n + e)). | L2262 | new |
| 237 | Lemma | ctr_bin | Lemma ctr_bin : ctr bin. | L2264 | new |
| 238 | Lemma | vfl_nil | Lemma vfl_nil m V : vfl [] m V = digits m V ++ uP :: bin (V / 2 ^ m). | L2267 | new |
| 239 | Lemma | ctr_vfl | Lemma ctr_vfl m : ctr (vfl [] m). | L2274 | new |
| 240 | Lemma | astep | Lemma astep X Yc n D j T0 e1 A X1 X3 : ctr Yc -> XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true -> T0 <= D + pj j -> shiftX (fill X1 (val X1 + (D + pj j + 3 * A - T0))) = Some X3 -> cs_step (X ++ Yc n) D j … +1 lines | L2284 | new |
| 241 | Lemma | vlow_L | Lemma vlow_L hs L L' R V : R < L -> R < L' -> vlow hs L R V = vlow hs L' R V. | L2308 | new |
| 242 | Lemma | vfl_split_hi | Lemma vfl_split_hi hs L R V : R < L -> length hs <= R -> vfl hs L V = vlow hs L R V ++ vfl [] (L - R) (V / 2 ^ R). | L2315 | new |
| 243 | Lemma | vfl_split_le | Lemma vfl_split_le hs L R V : L <= R -> 2 ^ R <= V -> vfl hs L V = vlow hs L R V ++ bin (V / 2 ^ R). | L2327 | new |
| 244 | Lemma | lsteqb_eq | Lemma lsteqb_eq a b : lsteqb a b = true -> a = b. | L2336 | new |
| 245 | Definition | vzf | Definition vzf (r : vrow) (o L : nat) (low : bool) : Z := (Z.of_nat (val_ r * o + vwp r) - Z.of_nat (vwn r) - (if low then Z.of_nat (3 * 2 ^ (L - 1)) else 0))%Z. | L2349 | new |
| 246 | Definition | vt0 | Definition vt0 (r : vrow) (off0 a : nat) (X1 : list unt) : Z := (Z.of_nat (val X1 + off0 + pj off0 + 3 * a) - Z.of_nat (64 + vd r + 4096))%Z. | L2352 | new |
| 247 | Definition | vsrun | Definition vsrun (r : vrow) (off0 Lc : nat) : option (list unt * N * nat * list unt * list unt) := match xfeed 4000 4096 (vlowN (vh r) Lc 8 (Z.to_N (vzf r off0 Lc (Nat.leb Lc 8) mod 256))) with | None => None | Some (Xt, e1) => match splitP Xt with | (a, X1) => … +6 lines | L2355 | new |
| 248 | Definition | vscond | Definition vscond (fx : bool) (r r' : vrow) (off0 Lc : nat) (e1 : N) (a : nat) (X1 X3 : list unt) : bool := let low := Nat.leb Lc 8 in let L2 := if low then Lc + ndig X3 - 8 else S (ndig X3) in dhead X1 && allb cleanu X1 && Nat.leb 5 Lc && Nat.leb Lc 9 && Nat.eqb (vlam r' + 8) (vlam r + 1 + ndig X3) && Nat.eqb (vd r' + a) (vd r + 1) && Nat.leb (length (vh r')) (ndig X3) && Nat.leb (length (vh r)) 8 && Nat.leb 9 (Lc + ndig X3) && … +6 lines | L2368 | new |
| 249 | Definition | vsok | Definition vsok (fx : bool) (r r' : vrow) (off0 Lc : nat) : bool := match vsrun r off0 Lc with | Some (Xt, e1, a, X1, X3) => vscond fx r r' off0 Lc e1 a X1 X3 | None => false end. | L2381 | new |
| 250 | Lemma | vsrun_spec | Lemma vsrun_spec r off0 Lc Xt e1 a X1 X3 : vsrun r off0 Lc = Some (Xt, e1, a, X1, X3) -> xfeed 4000 4096 (vlowN (vh r) Lc 8 (Z.to_N (vzf r off0 Lc (Nat.leb Lc 8) mod 256))) = Some (Xt, e1) /\ splitP Xt = (a, X1) /\ shiftX (fillN X1 (Z.to_N (vt0 r off0 a X1 mod 2 ^ Z.of_nat (ndig X1)))) = Some X3. | L2387 | new |
| 251 | Lemma | Zdm | Lemma Zdm (z : Z) (m : nat) : 0 < m -> z = (Z.of_nat m * (z / Z.of_nat m) + z mod Z.of_nat m)%Z /\ (0 <= z mod Z.of_nat m < Z.of_nat m)%Z. | L2401 | new |
| 252 | Lemma | pj_shift8 | Lemma pj_shift8 off0 a : a mod 8 = O -> pj (off0 + a) = pj off0. | L2405 | new |
| 253 | Lemma | vs_core | Lemma vs_core r r' L V L' V' X0 Yc n n' D j e1 A X1 r2 M2 X3 : ctr Yc -> vfl (vh r) L V = X0 ++ Yc n -> vfl (vh r') L' V' = X3 ++ Yc n' -> XN 4096 X0 e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true -> 4096 <= D + pj j -> val X1 + (D + pj j + 3 * A - 4096) = r2 + 2 ^ ndig X1 * M2 -> r2 < 2 ^ ndig X1 -> shiftX (fill X1 r2) = Some X3 -> n' = n + (e1 + M2) -> … +1 lines | L2411 | new |
| 254 | Lemma | Zpow_nat | Lemma Zpow_nat n : (2 ^ Z.of_nat n)%Z = Z.of_nat (2 ^ n). | L2429 | new |
| 255 | Lemma | pow_split | Lemma pow_split n : n <= 8 -> 2 ^ n * 2 ^ (8 - n) = 256. | L2432 | new |
| 256 | Lemma | ar_main | Lemma ar_main (mu al wp wn mu' al' wp' wn' w g off0 lc lc2 hc P1 P3 Pn Pn3 PL PL' vX p a vdr : nat) (e1 : N) (vz vz2 t0 : Z) : vz = (Z.of_nat (al * off0 + wp) - Z.of_nat wn - Z.of_nat lc)%Z -> vz2 = (Z.of_nat (al' * S off0 + wp') - Z.of_nat wn' - Z.of_nat lc2)%Z -> 3 * PL = lc + 768 * hc -> 3 * PL' = lc2 + 3 * Pn3 * hc -> Pn * P1 = 256 -> Pn3 * P3 = 256 -> 0 < Pn -> 0 < Pn3 -> … +15 lines | L2436 | new |
| 257 | Lemma | ar_pj | Lemma ar_pj w g off0 : off0 < 256 -> 4160 <= 256 * w + (off0 + 256 * g) -> pj (256 * w + (off0 + 256 * g) - 64) = pj off0. | L2508 | new |
| 258 | Lemma | if_true | Lemma if_true A (x y : A) : (if true then x else y) = x. | L2515 | new |
| 259 | Lemma | if_false | Lemma if_false A (x y : A) : (if false then x else y) = y. | L2518 | new |
| 260 | Lemma | vs_gen | Lemma vs_gen fx r r' off0 Lc g w k off : vsok fx r r' off0 Lc = true -> off0 < 256 -> off = off0 + 256 * g -> (fx = true -> g = O) -> (Lc <= 8 /\ k + vlam r - off = Lc \/ Lc = 9 /\ 9 <= k + vlam r - off) -> vwn r + 3 * 2 ^ (k + vlam r - off - 1) + 256 <= vmu r * (256 * w) + val_ r * off + vwp r -> 4096 + 64 + vd r <= 256 * w + off -> … +1 lines | L2521 | new |
| 261 | Definition | enrows | Definition enrows : list vrow := [ mkV [[]; [uS1]] 24 1 0 0 0 2; mkV [[]; [uSP]] 25 2 0 0 0 3; mkV [[uS1; uP; uP]] 24 1 0 0 2 4; mkV [[]; []; []; [uS1]] 24 1 0 0 0 2; mkV [[]; []; [uS1; uP]] 24 1 0 0 4 3; … +7 lines | L2661 | new |
| 262 | Definition | row1 | Definition row1 (off : nat) : vrow := if Nat.leb off 31 then nth (off - 20) enrows (phrow 0) else phrow (off mod 8). | L2675 | new |
| 263 | Definition | en_ok | Definition en_ok (i : nat) : bool := vsok true (row1 (20 + i)) (row1 (21 + i)) (20 + i) 9. | L2678 | new |
| 264 | Definition | lcs | Definition lcs : list nat := [5%nat; 6; 7; 8; 9]. | L2680 | new |
| 265 | Definition | ph_ok | Definition ph_ok (o : nat) : bool := forallb (fun Lc => vsok false (phrow (o mod 8)) (phrow (S o mod 8)) o Lc) lcs. | L2682 | new |
| 266 | Lemma | en_all | Lemma en_all : forallb en_ok (upto 12) = true. | L2691 | new |
| 267 | Lemma | ph_all | Lemma ph_all : forallb ph_ok (upto 256) = true. | L2694 | new |
| 268 | Definition | rowok | Definition rowok (r : vrow) : bool := Nat.leb 1 (vmu r) && Nat.leb (vwn r) 42 && Nat.leb (vd r) 5 && Nat.leb 24 (vlam r) && Nat.leb (vlam r) 25. | L2698 | new |
| 269 | Lemma | nth_rowok | Lemma nth_rowok l d n : forallb rowok l = true -> rowok d = true -> rowok (nth n l d) = true. | L2701 | new |
| 270 | Lemma | phrow_ok | Lemma phrow_ok phi : rowok (phrow phi) = true. | L2707 | new |
| 271 | Lemma | row1_ok | Lemma row1_ok off : rowok (row1 off) = true. | L2710 | new |
| 272 | Lemma | rowok_spec | Lemma rowok_spec r : rowok r = true -> 1 <= vmu r /\ vwn r <= 42 /\ vd r <= 5 /\ 24 <= vlam r <= 25. | L2713 | new |
| 273 | Lemma | row1_lam | Lemma row1_lam off : 20 <= off -> vlam (row1 off) <= off + 4. | L2719 | new |
| 274 | Lemma | mod8_256 | Lemma mod8_256 off : (off mod 256) mod 8 = off mod 8. | L2730 | new |
| 275 | Lemma | Smod8_256 | Lemma Smod8_256 off : S (off mod 256) mod 8 = S off mod 8. | L2737 | new |
| 276 | Lemma | en_at | Lemma en_at i : i < 12 -> vsok true (row1 (20 + i)) (row1 (21 + i)) (20 + i) 9 = true. | L2746 | new |
| 277 | Lemma | ph_at | Lemma ph_at o Lc : o < 256 -> In Lc lcs -> vsok false (phrow (o mod 8)) (phrow (S o mod 8)) o Lc = true. | L2749 | new |
| 278 | Lemma | vs_ph | Lemma vs_ph k w off : 5 <= k + vlam (phrow (off mod 8)) - off -> vwn (phrow (off mod 8)) + 3 * 2 ^ (k + vlam (phrow (off mod 8)) - off - 1) + 256 <= vmu (phrow (off mod 8)) * (256 * w) + val_ (phrow (off mod 8)) * off + vwp (phrow (off mod 8)) -> 4096 + 64 + vd (phrow (off mod 8)) <= 256 * w + off -> CS (vfz (phrow (off mod 8)) k (256 * w) off) (vfz (phrow (S off mod 8)) k (256 * w) (S off)). | L2757 | new |
| 279 | Lemma | vs_en | Lemma vs_en k w off : 20 <= off <= 31 -> 9 <= k + vlam (row1 off) - off -> vwn (row1 off) + 3 * 2 ^ (k + vlam (row1 off) - off - 1) + 256 <= vmu (row1 off) * (256 * w) + val_ (row1 off) * off + vwp (row1 off) -> 4096 + 64 + vd (row1 off) <= 256 * w + off -> CS (vfz (row1 off) k (256 * w) off) (vfz (row1 (S off)) k (256 * w) (S off)). | L2779 | new |
| 280 | Inductive | CSstar | Inductive CSstar : st -> st -> Prop := | CSs0 s : CSstar s s | CSsS s s1 s' : CS s s1 -> CSstar s1 s' -> CSstar s s'. | L2793 | new |
| 281 | Lemma | CSstar_snoc | Lemma CSstar_snoc a b c : CSstar a b -> CS b c -> CSstar a c. | L2797 | new |
| 282 | Lemma | CSstar_plus | Lemma CSstar_plus a b c : CSstar a b -> CSplus b c -> CSplus a c. | L2804 | new |
| 283 | Lemma | descent | Lemma descent (rowf : nat -> vrow) k Om a b : (forall x, a <= x < b -> CS (vfz (rowf x) k Om x) (vfz (rowf (S x)) k Om (S x))) -> a <= b -> CSstar (vfz (rowf a) k Om a) (vfz (rowf b) k Om b). | L2811 | new |
| 284 | Lemma | off_end_L5 | Lemma off_end_L5 k x l : x < off_end k -> 24 <= l -> (x = k + 20 -> l = 25) -> 5 <= k + l - x. | L2828 | new |
| 285 | Lemma | off_end_phase3 | Lemma off_end_phase3 k x : x < off_end k -> x = k + 20 -> x mod 8 = 3. | L2835 | new |
| 286 | Lemma | pow_ge | Lemma pow_ge k a : a <= k -> 2 ^ a <= 2 ^ k. | L2841 | new |
| 287 | Theorem | VF1 | Theorem VF1 k o : 41 <= k -> 1 <= o -> CSstar (vfz (row1 20) k (o * 2 ^ (k + 5)) 20) (VFe k (o * 2 ^ (k + 5))). | L2844 | new |
| 288 | Theorem | VF2 | Theorem VF2 v S : 12 <= v -> 2 <= S -> CSstar (vfz (phrow 1) (v - 10) (S * 2 ^ v) 17) (VFe (v - 10) (S * 2 ^ v)). | L2883 | new |
| 289 | Lemma | bin_pow_odd | Lemma bin_pow_odd i q : bin (2 ^ i * (2 * q + 1)) = repeat uD0 i ++ uD1 :: bin q. | L2916 | new |
| 290 | Lemma | shift_D0s | Lemma shift_D0s m w : shift (repeat uD0 m ++ w) = match shift w with Some w' => Some (repeat uD0 m ++ w') | None => None end. | L2929 | new |
| 291 | Lemma | pj17 | Lemma pj17 b : pj (32 * b + 17) = 48. | L2936 | new |
| 292 | Lemma | cs_step_conv | Lemma cs_step_conv Z D j Z' D1 j1 D2 j2 : cs_step Z D j Z' D1 j1 -> D1 = D2 -> j1 = j2 -> cs_step Z D j Z' D2 j2. | L2941 | new |
| 293 | Lemma | E1 | Lemma E1 k q : 41 <= k -> let b := (2 * q + 1) * 2 ^ k - 2 in CS (Cst b) (repeat uD0 (k + 6) ++ uS1 :: bin q, 32 * b + 17, 32 * b + 18). | L2944 | new |
| 294 | Definition | s1w | Definition s1w (q : nat) : list unt := if Nat.eqb q 0 then [uS1] else uP :: bin (2 * q - 1). | L2990 | new |
| 295 | Lemma | IncN_s1w | Lemma IncN_s1w q : IncN q (uS1 :: bin q) (s1w q). | L2992 | new |
| 296 | Lemma | digits_pow2 | Lemma digits_pow2 i : digits (S i) (2 ^ i) = repeat uD0 i ++ [uD1]. | L2999 | new |
| 297 | Lemma | pj18 | Lemma pj18 b : pj (32 * b + 18) = 48. | L3006 | new |
| 298 | Lemma | odd_half | Lemma odd_half q P : 0 < P -> (2 * q + 1) * P / (2 * P) = q. | L3011 | new |
| 299 | Lemma | E2 | Lemma E2 k q : 41 <= k -> let b := (2 * q + 1) * 2 ^ k - 2 in CS (repeat uD0 (k + 6) ++ uS1 :: bin q, 32 * b + 17, 32 * b + 18) (uS1 :: repeat uD0 (k + 4) ++ uD1 :: s1w q, 32 * b + 17, 32 * b + 19). | L3016 | new |
| 300 | Lemma | pj19 | Lemma pj19 b : pj (32 * b + 19) = 47. | L3063 | new |
| 301 | Lemma | IncN_s1w_up | Lemma IncN_s1w_up q : IncN (2 * q + 1) (s1w q) (uP :: bin (4 * q)). | L3068 | new |
| 302 | Lemma | E3 | Lemma E3 k q : 41 <= k ->
let b := (2 * q + 1) * 2 ^ k - 2 in
CS (uS1 :: repeat uD0 (k + 4) ++ uD1 :: s1w q, 32 * b + 17, 32 * b + 19)
([uD0; uS1; uD0; uD0; uD0; uD0; uD0; uD0] ++ digits (k - 3) (2 ^ (k - 4)) ++ uP :: bin (4 * q),
32 * b + 18, 32 * b + 20). | L3075 | new |
| 303 | Lemma | vfl_row20 | Lemma vfl_row20 m W : vfl [[]; [uS1]] (S (S m)) (4 * W) = uD0 :: uS1 :: uD0 :: vfl [] m W. | L3125 | new |
| 304 | Lemma | E_id | Lemma E_id k q : 41 <= k -> let b := (2 * q + 1) * 2 ^ k - 2 in ([uD0; uS1; uD0; uD0; uD0; uD0; uD0; uD0] ++ digits (k - 3) (2 ^ (k - 4)) ++ uP :: bin (4 * q), 32 * b + 18, 32 * b + 20) = vfz (row1 20) k ((2 * q + 1) * 2 ^ (k + 5)) 20. | L3133 | new |
| 305 | Theorem | LemmaE | Theorem LemmaE k q : 41 <= k -> CSplus (Cst ((2 * q + 1) * 2 ^ k - 2)) (vfz (row1 20) k ((2 * q + 1) * 2 ^ (k + 5)) 20). | L3161 | new |
| 306 | Lemma | pjg | Lemma pjg g i : pj (8 * g + i) = pj i. | L3175 | new |
| 307 | Lemma | digits_0 | Lemma digits_0 n : digits n 0 = repeat uD0 n. | L3180 | new |
| 308 | Lemma | digits_snoc | Lemma digits_snoc m x : x < 2 ^ m -> digits (S m) x = digits m x ++ [uD0]. | L3186 | new |
| 309 | Lemma | IncN_dig_q | Lemma IncN_dig_q r v t p v' rest rest' : v' < 2 ^ r -> v + t = v' + 2 ^ r * p -> v < 2 ^ r -> IncN p rest rest' -> IncN t (digits r v ++ rest) (digits r v' ++ rest'). | L3197 | new |
| 310 | Lemma | XN_clean_q | Lemma XN_clean_q X t vx nd x p : allb cleanu X = true -> val X = vx -> ndig X = nd -> x < 2 ^ nd -> vx + t = x + 2 ^ nd * p -> XN t X p (fill X x). | L3206 | new |
| 311 | Lemma | pstep | Lemma pstep X Y T0 e1 A X1 vx nd x p X3 Y' D j D' j' : XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true -> val X1 = vx -> ndig X1 = nd -> x < 2 ^ nd -> vx + (D + pj j + 3 * A - T0) = x + 2 ^ nd * p -> T0 <= D + pj j -> IncN (e1 + p) Y Y' -> shiftX (fill X1 x) = Some X3 -> D' = D + A -> j' = S j -> CS (X ++ Y, D, j) (X3 ++ Y', D', j'). | L3215 | new |
| 312 | Lemma | cs_nodrop | Lemma cs_nodrop Z D j Y Z' : dhead Z = true -> IncN (D + pj j) Z Y -> shift Y = Some Z' -> CS (Z, D, j) (Z', D, S j). | L3231 | new |
| 313 | Lemma | Inc_W3 | Lemma Inc_W3 w w3 w4 : IncN 3 w w3 -> shift w3 = Some w4 -> Inc (uW :: w) (uP :: w4). | L3243 | new |
| 314 | Lemma | s1w_pos | Lemma s1w_pos Q : 1 <= Q -> s1w Q = uP :: bin (2 * Q - 1). | L3249 | new |
| 315 | Definition | gP | Definition gP (n Q : nat) : nat := (2 * Q + 1) * 2 ^ n - 8. | L3252 | new |
| 316 | Lemma | HW | Lemma HW n : 7 <= n -> 128 <= 2 ^ n. | L3254 | new |
| 317 | Lemma | Hg | Lemma Hg n Q : 7 <= n -> 8 * gP n Q + 64 = 8 * ((2 * Q + 1) * 2 ^ n). | L3257 | new |
| 318 | Lemma | vfl_S1 | Lemma vfl_S1 m V : 1 <= m -> vfl [[uS1]] m V = uS1 :: digits m V ++ uP :: bin (V / 2 ^ m). | L3260 | new |
| 319 | Lemma | digits_snoc' | Lemma digits_snoc' m x : 1 <= m -> x < 2 ^ (m - 1) -> digits m x = digits (m - 1) x ++ [uD0]. | L3266 | new |
| 320 | Lemma | P12 | Lemma P12 n Q : 7 <= n -> 1 <= Q -> CS ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q), 8 * gP n Q + 8, 8 * gP n Q + 12) ([uD0; uD0; uD0; uSP] ++ digits n (2 ^ n - 3) ++ bin (4 * Q + 1), 8 * gP n Q + 11, 8 * gP n Q + 13). | L3269 | new |
| 321 | Lemma | P13 | Lemma P13 n Q : 7 <= n -> 1 <= Q -> CS ([uD0; uD0; uD0; uSP] ++ digits n (2 ^ n - 3) ++ bin (4 * Q + 1), 8 * gP n Q + 11, 8 * gP n Q + 13) ([uD0; uS1; uD0; uP] ++ digits n (2 ^ n - 3) ++ uD0 :: s1w Q, 8 * gP n Q + 11, 8 * gP n Q + 14). | L3286 | new |
| 322 | Lemma | P14 | Lemma P14 n Q : 7 <= n -> 1 <= Q -> CS ([uD0; uS1; uD0; uP] ++ digits n (2 ^ n - 3) ++ uD0 :: s1w Q, 8 * gP n Q + 11, 8 * gP n Q + 14) ([uS1; uP; uD0; uP] ++ digits n (2 ^ n - 5) ++ uD0 :: uP :: bin (4 * Q), 8 * gP n Q + 11, 8 * gP n Q + 15). | L3318 | new |
| 323 | Lemma | P15 | Lemma P15 n Q : 7 <= n -> 1 <= Q -> CS ([uS1; uP; uD0; uP] ++ digits n (2 ^ n - 5) ++ uD0 :: uP :: bin (4 * Q), 8 * gP n Q + 11, 8 * gP n Q + 15) ([uS1; uP] ++ digits n (2 ^ n - 6) ++ uD0 :: uP :: bin (8 * Q + 2), 8 * gP n Q + 13, 8 * gP n Q + 16). | L3342 | new |
| 324 | Lemma | P16 | Lemma P16 n Q : 7 <= n -> 1 <= Q -> CS ([uS1; uP] ++ digits n (2 ^ n - 6) ++ uD0 :: uP :: bin (8 * Q + 2), 8 * gP n Q + 13, 8 * gP n Q + 16) ([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17). | L3366 | new |
| 325 | Theorem | LemmaP | Theorem LemmaP n Q : 7 <= n -> 1 <= Q ->
CSplus ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q), 8 * gP n Q + 8, 8 * gP n Q + 12)
([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17). | L3396 | new |
| 326 | Lemma | P_id | Lemma P_id n Q : 7 <= n -> 1 <= Q -> ([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17) = vfz (phrow 1) (n - 7) ((2 * Q + 1) * 2 ^ (n + 3)) 17. | L3406 | new |
| 327 | Lemma | vfl_plant | Lemma vfl_plant y : vfl [[uS1; uP; uP]] 3 (8 * y) = [uS1; uP; uP; uD0; uD0; uD0; uP] ++ bin y. | L3425 | new |
| 328 | Lemma | VFe_plant | Lemma VFe_plant K Om n Q : 7 <= n -> 1 <= Q -> (K + 9) mod 8 = O -> 41 <= K ->
Om + K + 9 = (2 * Q + 1) * 2 ^ (n + 3) ->
VFe K Om = ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q),
8 * gP n Q + 8, 8 * gP n Q + 12). | L3437 | new |
| 329 | Theorem | EK | Theorem EK K : 41 <= K -> forall U, 1 <= U -> exists b', CSplus (VFe K (U * 2 ^ (K + 5))) (Cst b'). | L3466 | new |
| 330 | Theorem | thmB | Theorem thmB b : exists b', CSplus (Cst b) (Cst b'). | L3516 | new |
| 331 | Definition | CSr | Definition CSr (s : st) : Prop := CSreach (fst (fst s)) (snd (fst s)) (snd s). | L3533 | new |
| 332 | Lemma | CSplus_reach | Lemma CSplus_reach s s' : CSr s -> CSplus s s' -> CSr s'. | L3535 | new |
| 333 | Lemma | all_Cst | Lemma all_Cst N0 : exists b, N0 <= b /\ CSr (Cst b). | L3542 | new |
| 334 | Lemma | CSreach_down | Lemma CSreach_down Z D j : CSreach Z D j -> forall j', 1 <= j' <= j -> exists Z' D', CSreach Z' D' j'. | L3551 | new |
| 335 | Theorem | zone_forever | Theorem zone_forever J : 1 <= J -> exists Z D, CSreach Z D J. | L3561 | new |
| 336 | Lemma | cs_step_j | Lemma cs_step_j Z D j Z' D' j' : cs_step Z D j Z' D' j' -> j' = S j. | L3574 | new |
| 337 | Lemma | cs_step_det | Lemma cs_step_det Z D j Z1 D1 j1 Z2 D2 j2 : cs_step Z D j Z1 D1 j1 -> cs_step Z D j Z2 D2 j2 -> Z1 = Z2 /\ D1 = D2. | L3577 | new |
| 338 | Lemma | CSreach_pos | Lemma CSreach_pos Z D j : CSreach Z D j -> 1 <= j. | L3592 | new |
| 339 | Lemma | CSreach_det | Lemma CSreach_det Z1 D1 j : CSreach Z1 D1 j -> forall Z2 D2, CSreach Z2 D2 j -> Z1 = Z2 /\ D1 = D2. | L3595 | new |
| 340 | Theorem | CS_next | Theorem CS_next Z D j : CSreach Z D j -> exists Z' D', cs_step Z D j Z' D' (S j). | L3609 | new |
| 341 | Lemma | leading_P | Lemma leading_P w : exists a y, w = Ps a ++ y /\ notP y. | L3619 | new |
| 342 | Lemma | IncN_le | Lemma IncN_le m m' Z Y : m' <= m -> IncN m Z Y -> exists Y', IncN m' Z Y'. | L3628 | new |
| 343 | Lemma | odd_plus2 | Lemma odd_plus2 n : Nat.odd (n + 2) = Nat.odd n. | L3639 | new |
| 344 | Lemma | Ps_add | Lemma Ps_add a b x : Ps a ++ Ps b ++ x = Ps (a + b) ++ x. | L3642 | new |
| 345 | Lemma | Pops_wall | Lemma Pops_wall f a (b : bool) r r' :
Pops ((3 * f + Nat.b2n b) / 2) r r' ->
Pops f (Ps a ++ wallu b :: r)
(Ps (a + (3 * f + Nat.b2n b) / 2 - f) ++ wallu (Nat.odd (3 * f + Nat.b2n b)) :: r'). | L3645 | new |
| 346 | Definition | u0b | Definition u0b : list Z := [32; 20; 12; 7; 3; 1]%Z. | L3687 | new |
| 347 | Definition | u0s | Definition u0s : list nat := [1; 1; 1; 0; 1; 0]%nat. | L3688 | new |
| 348 | Definition | u0H | Definition u0H : list nat := [0; 0; 0; 0; 0; 9]%nat. | L3689 | new |
| 349 | Definition | phb | Definition phb : list Z := [2; 0; -1; 10; 5; 2; 0; 1]%Z. | L3690 | new |
| 350 | Definition | phs | Definition phs : list nat := [0; 1; 1; 0; 0; 1; 1; 0]%nat. | L3691 | new |
| 351 | Definition | phH | Definition phH : list nat := [0; 0; 36; 0; 0; 0; 6; 9]%nat. | L3692 | new |
| 352 | Definition | wb | Definition wb (w : nat) : Z := if Nat.ltb w 6 then nth w u0b 0%Z else nth ((w - 6) mod 8) phb 0%Z. | L3694 | new |
| 353 | Definition | wsb | Definition wsb (w : nat) : nat := if Nat.ltb w 6 then nth w u0s O else nth ((w - 6) mod 8) phs O. | L3695 | new |
| 354 | Definition | wH | Definition wH (w : nat) : nat := if Nat.ltb w 6 then nth w u0H O else nth ((w - 6) mod 8) phH O. | L3696 | new |
| 355 | Definition | bracket_ok | Definition bracket_ok (J : nat) : bool :=
Z.eqb (Z.of_nat (pj J))
(43 - 3 * wb J + 2 * wb (J - 1) + Z.of_nat (wsb (J - 1)) + Z.of_nat (wH (J - 1)))%Z. | L3699 | new |
| 356 | Lemma | bracket_small | Lemma bracket_small : forallb bracket_ok [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14]%nat = true. | L3703 | new |
| 357 | Lemma | wdata_period | Lemma wdata_period w : 6 <= w -> wb (w + 8) = wb w /\ wsb (w + 8) = wsb w /\ wH (w + 8) = wH w. | L3706 | new |
| 358 | Theorem | bracket | Theorem bracket J : 1 <= J -> bracket_ok J = true. | L3713 | new |
| 359 | Lemma | wb_ge | Lemma wb_ge w : (-1 <= wb w)%Z. | L3740 | new |
| 360 | Lemma | wb_le | Lemma wb_le w : (wb w <= 32)%Z. | L3751 | new |
| 361 | Lemma | wsb_le | Lemma wsb_le w : wsb w <= 1. | L3762 | new |
| 362 | Definition | bq | Definition bq (w : nat) : nat := Z.to_nat (wb w + 1). | L3773 | new |
| 363 | Definition | fw | Definition fw (w R : nat) : nat := (R + wsb w) / 2. | L3774 | new |
| 364 | Definition | posw | Definition posw (w R : nat) : nat := bq w + fw w R. | L3775 | new |
| 365 | Definition | Rab | Definition Rab (w D : nat) : nat := 2 * (44 + D - bq w) - wsb w. | L3776 | new |
| 366 | Lemma | bq_spec | Lemma bq_spec w : Z.of_nat (bq w) = (wb w + 1)%Z. | L3778 | new |
| 367 | Lemma | bq_le | Lemma bq_le w : bq w <= 33. | L3781 | new |
| 368 | Lemma | bracket_nat | Lemma bracket_nat w : pj (S w) + 3 * bq (S w) = 44 + 2 * bq w + wsb w + wH w. | L3785 | new |
| 369 | Definition | nofix | Definition nofix (Z : list unt) (D J m : nat) : Prop := forall A Y, IncN m Z (Ps A ++ Y) -> notP Y -> m <> D + pj J + 3 * A. | L3792 | new |
| 370 | Definition | ZoneR | Definition ZoneR (J m p : nat) (u : list unt) : Prop := exists Z D A Y, CSreach Z D J /\ IncN m Z (Ps A ++ Y) /\ notP Y /\ (forall m', m' < m -> nofix Z D J m') /\ p <= 44 + D + A /\ u = Ps (44 + D + A - p) ++ Y. | L3796 | new |
| 371 | Definition | Zone0 | Definition Zone0 (m p : nat) (u : list unt) : Prop := m <= 33 /\ p <= 44 /\ u = Ps (44 - p) ++ bin (60 + m). | L3802 | new |
| 372 | Fixpoint | WdR | Fixpoint WdR (w p R : nat) (u : list unt) : Prop := (exists Z D, CSreach Z D (S w) /\ Rab w D <= R /\ ZoneR (S w) (R - Rab w D) p u) \/ ((forall Z D, CSreach Z D (S w) -> R < Rab w D) /\ p <= posw w R /\ exists u', u = Ps (posw w R - p) ++ wallu (Nat.odd (R + wsb w)) :: u' /\ match w with | O => Zone0 (3 * fw 0 R) (S (posw 0 R)) u' … +2 lines | L3806 | new |
| 373 | Lemma | WdR_eq | Lemma WdR_eq w p R u : WdR w p R u <-> (exists Z D, CSreach Z D (S w) /\ Rab w D <= R /\ ZoneR (S w) (R - Rab w D) p u) \/ ((forall Z D, CSreach Z D (S w) -> R < Rab w D) /\ p <= posw w R /\ exists u', u = Ps (posw w R - p) ++ wallu (Nat.odd (R + wsb w)) :: u' /\ match w with | O => Zone0 (3 * fw 0 R) (S (posw 0 R)) u' … +2 lines | L3815 | new |
| 374 | Definition | Can | Definition Can (w R : nat) : Prop := forall Z D, CSreach Z D (S w) -> Rab w D <= R -> (exists Y', IncN (S (R - Rab w D)) Z Y') /\ nofix Z D (S w) (R - Rab w D). | L3826 | new |
| 375 | Lemma | Inc_Ps | Lemma Inc_Ps a y y' : Inc y y' -> Inc (Ps a ++ y) (Ps a ++ y'). | L3832 | new |
| 376 | Lemma | Ps_snoc | Lemma Ps_snoc a x : Ps a ++ uP :: x = Ps (S a) ++ x. | L3835 | new |
| 377 | Lemma | Ps_P_cons | Lemma Ps_P_cons n y t : Ps n ++ y = uP :: t -> notP y -> 1 <= n /\ t = Ps (n - 1) ++ y. | L3838 | new |
| 378 | Lemma | notP_wall | Lemma notP_wall b x : notP (wallu b :: x). | L3845 | new |
| 379 | Lemma | shift_notP | Lemma shift_notP Y Z' : notP Y -> shift Y = Some Z' -> notP Z'. | L3848 | new |
| 380 | Lemma | Ps_le | Lemma Ps_le a b y y' : Ps a ++ y = Ps b ++ y' -> notP y' -> a <= b. | L3857 | new |
| 381 | Lemma | fw_even | Lemma fw_even w R : Nat.odd (R + wsb w) = false -> fw w (S R) = fw w R. | L3865 | new |
| 382 | Lemma | fw_odd | Lemma fw_odd w R : Nat.odd (R + wsb w) = true -> fw w (S R) = S (fw w R). | L3873 | new |
| 383 | Lemma | odd_S_false | Lemma odd_S_false w R : Nat.odd (R + wsb w) = true -> Nat.odd (S R + wsb w) = false. | L3881 | new |
| 384 | Lemma | odd_S_true | Lemma odd_S_true w R : Nat.odd (R + wsb w) = false -> Nat.odd (S R + wsb w) = true. | L3884 | new |
| 385 | Lemma | fw_mono | Lemma fw_mono w R R' : R <= R' -> fw w R <= fw w R'. | L3887 | new |
| 386 | Lemma | fw_add3 | Lemma fw_add3 w R : S (fw w R) <= fw w (R + 3). | L3890 | new |
| 387 | Lemma | Rab_parity | Lemma Rab_parity w D R : Nat.odd (R + wsb w) = false -> R < Rab w D -> S R < Rab w D. | L3896 | new |
| 388 | Lemma | below | Lemma below Z D J ms As Ys : IncN ms Z (Ps As ++ Ys) -> notP Ys -> (forall m', m' < ms -> nofix Z D J m') -> forall m A Y, m <= ms -> IncN m Z (Ps A ++ Y) -> notP Y -> m <= D + pj J + 3 * A. | L3906 | new |
| 389 | Lemma | zone_at | Lemma zone_at J : 1 <= J -> exists Z D Z' D', CSreach Z D J /\ cs_step Z D J Z' D' (S J) /\ CSreach Z' D' (S J). | L3920 | new |
| 390 | Lemma | WdR_pop | Lemma WdR_pop w p R t : WdR w p R (uP :: t) -> WdR w (S p) R t. | L3930 | new |
| 391 | Lemma | bin_notP | Lemma bin_notP v : notP (bin v). | L3942 | new |
| 392 | Lemma | Ps_P_cons' | Lemma Ps_P_cons' n y : 1 <= n -> exists t, Ps n ++ y = uP :: t. | L3947 | new |
| 393 | Lemma | zone_carry | Lemma zone_carry J m p u : ZoneR J m p u -> (forall Z D, CSreach Z D J -> (exists Y', IncN (S m) Z Y') /\ nofix Z D J m) -> exists u', Inc u u' /\ ZoneR J (S m) p u'. | L3951 | new |
| 394 | Lemma | Can_lt | Lemma Can_lt w' R0 Z D ms As Ys : CSreach Z D (S w') -> IncN ms Z (Ps As ++ Ys) -> (forall m', m' < ms -> nofix Z D (S w') m') -> R0 < Rab w' D + ms -> Can w' R0. | L3975 | new |
| 395 | Lemma | cs_step_min | Lemma cs_step_min Z D j Z' D' j' : cs_step Z D j Z' D' j' -> exists ms As Ys, IncN ms Z (Ps As ++ Ys) /\ notP Ys /\ ms = D + pj j + 3 * As /\ (forall m', m' < ms -> nofix Z D j m') /\ shift Ys = Some Z' /\ D' = D + As. | L3986 | new |
| 396 | Lemma | fw_val | Lemma fw_val w R k : R + wsb w = 2 * k + 1 -> fw w R = k. | L3996 | new |
| 397 | Lemma | cascade | Lemma cascade w : forall p R u, WdR w p R u -> Can w R -> exists u', Inc u u' /\ WdR w p (S R) u'. | L3999 | new |
| 398 | Lemma | cascadeN | Lemma cascadeN w p R u t : WdR w p R u -> (forall i, i < t -> Can w (R + i)) -> exists u', IncN t u u' /\ WdR w p (R + t) u'. | L4165 | new |
| 399 | Lemma | live_small | Lemma live_small w R : R < 2 * (44 - bq w) - wsb w -> forall Z D, CSreach Z D (S w) -> R < Rab w D. | L4176 | new |
| 400 | Lemma | Can_live | Lemma Can_live w R : R < 2 * (44 - bq w) - wsb w -> Can w R. | L4179 | new |
| 401 | Lemma | Pops_bottom | Lemma Pops_bottom Y k b R u : WdR Y b R u -> R + 3 * k < 2 * (44 - bq Y) - wsb Y -> exists u', Pops k u u' /\ WdR Y (b + k) (R + 3 * k) u'. | L4182 | new |
| 402 | Lemma | WdR_push | Lemma WdR_push w p q R0 u bqv sv : WdR w q R0 u -> R0 = wH w -> bq (S w) = bqv -> wsb (S w) = sv -> sv <= 1 -> p <= bqv -> S bqv = q -> 0 < 2 * (44 - bqv) - sv -> WdR (S w) p 0 (Ps (bqv - p) ++ wallu (Nat.odd sv) :: u). | L4205 | new |
| 403 | Lemma | wdata5 | Lemma wdata5 w : 5 <= w -> wb w = nth ((w + 2) mod 8) phb 0%Z /\ wsb w = nth ((w + 2) mod 8) phs O /\ wH w = nth ((w + 2) mod 8) phH O. | L4218 | new |
| 404 | Lemma | wd | Lemma wd w r : 5 <= w -> (w + 2) mod 8 = r -> bq w = Z.to_nat (nth r phb 0%Z + 1) /\ wsb w = nth r phs O /\ wH w = nth r phH O. | L4227 | new |
| 405 | Lemma | mod8_S | Lemma mod8_S w r : (w + 2) mod 8 = r -> (S w + 2) mod 8 = (S r) mod 8. | L4234 | new |
| 406 | Lemma | mod8_S' | Lemma mod8_S' w r r' : (w + 2) mod 8 = r -> S r mod 8 = r' -> (S w + 2) mod 8 = r'. | L4241 | new |
| 407 | Definition | rbase | Definition rbase (t : rt) : nat := match t with YC | YD | YE => O | _ => 1%nat end. | L4244 | new |
| 408 | Definition | rph | Definition rph (t : rt) : nat := match t with XC | XD | XE => 7%nat | YC | YD | YE => 2%nat | _ => 6%nat end. | L4245 | new |
| 409 | Definition | RInv | Definition RInv (t : rt) (U : list unt) : Prop := exists Y, 5 <= Y /\ (Y + 2) mod 8 = rph t /\ WdR Y (rbase t) 0 U. | L4247 | new |
| 410 | Lemma | bq_small | Lemma bq_small w : 5 <= w -> bq w <= 12. | L4250 | new |
| 411 | Lemma | RInv_step | Lemma RInv_step t U : RInv t U -> exists U', Pops (rk t) U U' /\ RInv (rnext t) (rF t ++ U'). | L4257 | new |
| 412 | Lemma | RInv_U0 | Lemma RInv_U0 : RInv XC U0. | L4304 | new |
| 413 | Lemma | Pops_det | Lemma Pops_det k U U1 U2 : Pops k U U1 -> Pops k U U2 -> U1 = U2. | L4319 | new |
| 414 | Lemma | Reach_RInv | Lemma Reach_RInv t U : Reach t U -> RInv t U. | L4330 | new |
| 415 | Theorem | AbsDefined_proof | Theorem AbsDefined_proof : AbsDefined. | L4338 | new |
| 416 | Lemma | nonhalt | Lemma nonhalt: ~halts tm c0. | L4343 | adapted |
4What a maintainer readsCheck: the rule table below is what the .v proves, and proof.md / README read cleanly for a maintainer.
- submission/proof.md · informal proof (submitted copy)
- submission/README.md · the package README
- submission/discord.md · Discord draft (not posted)
- proof.md (working copy) · differs from the submitted copy
submission/proof.md line 126: 2. Rules
2.1 Base macros
Each sweep is proved by induction on n, with one use of the induction hypothesis (S1).
SR B> (11000)^n --> (10111)^n B> 5n B1 E1 E0 F0 A0 per block
SR6 B> (111000)^n --> (100111)^n B> 6n
KB B> (1000)^n --> (1111)^n B> 4n B1 E0 F0 A0 per block
SL' (10111)^n <C --> <C (11000)^n 5n C1 C1 C1 C0 D1 per block
SL (11110)^n <C --> <C (00011)^n 5n
KC 1^n <C --> <C 0^n n C1
EdgeL 0^inf <C --> 0^inf 1 0 B> 1 4 C0 D0 E0 F1
2.2 Unit lemmas
Arrival. Write Arr(w) = w' (in s steps) for
l B> w 0^inf -->(s) l <C w' 0^inf
for every left context l. The head never moves left of w's first cell until the last step, and the last step moves it off w to the left in state C.
Oracle proof. Each unit lemma below is proved by running the machine on the unit's own cells alone, with the rest r of the word replaced by an oracle:
- When the head steps onto r's first cell, it must be in state B. The hypothesis Arr(r) = r' then returns the head to the unit's last cell in state C, with r replaced by r'.
- Any other contact with r, or a halt, fails the lemma.
These are finite computations (S2). Here are the chains:
unit lemmas: unit . r --> unit' . r' (r' = result of the nested arrivals Arr(r), Arr(Arr(r)), ...)
Z first cell 0 (D0, S1, SP, and every 0-led head; also the blank top):
B> 0 x --> <C 1 x 1 B0
D1 B> 1000 r --> 1111 B> r ~Arr~> 1111 <C r' --> <C 0000 r' 4 + 4
P B> 11000 r --> 10111 B> r ~Arr~> 10111 <C r' --> <C 11000 r' 5 + 5 (SR, SL')
W B> 111000 r --> 100111 B> r ~Arr~> 100111 <C r' --> 000111 B> r' 6, 11
~Arr~> 000111 <C r'' --> 101111 B> r'' ~Arr~> 101111 <C r''' --> <C 110000 r''' 11, 6
i.e. W r --> P . shift(inc^3 r) kappa = 34
stacked heads (needed only to show what a hit does; never reached, section 6):
111 B> 1111000 r --> 1000111 B> r ~> 1000111 <C r' --> 1101111 B> r' ~> 1101111 <C r'' --> <C 0110000 r''
i.e. 111 . r --> SP . shift(inc^2 r) kappa = 25
101 101 . r --> SP . shift(inc r) kappa = 14
1111 1111 . r --> 111 . shift(inc^2 r) kappa = 27
1101 1101 . r --> 111 . shift(inc r) kappa = 16
depth 4: 11111 and 11101 have no oracle proof (state E walks onto r); 01111 -> 11111, 01101 -> 11101 by Z.
Here shift(x) means the extra 0 cell 0 x, re-tokenised as in §1. The cell identity h 1000 0 x = h 1000 . shift(x) is pure re-reading, so no machine step is involved.
The W lemma holds for every left context l, and §4 uses this.
What a hit does (aside, not used). The main argument excludes every hit. A hit on SP or W gives the stacked heads 001 or 011, which have rows above. A hit on S1 gives head 00.
The next carry on 00 meets head 10, which has no unit rule. Its oracle run gives 101000 -> 011100 in 7 steps, which takes a cell from the unit above. A shift that lands on 001 gives 0001, which is not a valid head. So a stacked unit can leave the unit calculus in more than one way, and the proof never lets one arise.
2.3 Theorem U (arrival = inc)
Define the relation Inc(w, w', s) ("one carry turns w into w' in s machine steps") inductively by the table in §2.2:
Inc(0^inf, D1, 1)(the top case);- first cell 0:
Inc(0 x, 1 x, 1); - D1: if
Inc(r, r', s)thenInc(D1 . r, D0 . r', 8 + s); - P: if
Inc(r, r', s)thenInc(P . r, P . r', 10 + s); - W: if
Inc(r, r1, s1),Inc(r1, r2, s2)andInc(r2, r3, s3), thenInc(W . r, P . shift(r3), 34 + s1 + s2 + s3); - the stacked heads 111, 101, 1111 and 1101 follow their rows in the same way (κ = 25, 14, 27, 16).
inc(w) is defined when some (then unique) w', s with Inc(w, w', s) exist. That is, the recursion is finite and never meets a head outside the table.
Theorem U. If Inc(w, w', s), then Arr(w) = w' in exactly s machine steps.
Proof. Induction on the derivation of Inc(w, w', s). The last rule used is the unit lemma of w's first unit (§2.2). Its oracle calls are exactly the premises of that rule, which are smaller derivations.
So the induction hypothesis turns each oracle call into a real machine run, ending on the unit's last cell in state C as the oracle requires. Re-tokenising after a shift is a cell identity. ∎
The induction is on the derivation, not on the cell length of w. W's second and third oracle calls are on inc(r) and inc²(r), which need not be shorter than w.
Lemma U-term (termination). Let w ∈ L_gap have n units, and suppose no W firing inside the recursion for inc(w) is a hit. Then inc(w) is defined.
Proof. We prove a stronger statement by induction on the number of walls (SP and W units) of w:
If w ∈ L_gap and no W firing inside the recursion for inc(w) is a hit, then inc(w) is defined, inc(w) ∈ L_gap, and inc(w) has at most as many walls as w.
-
No wall creation. The rows never raise the wall count. SP becomes W on a carry. W becomes P when it fires, and its shift turns at most one unit above into a wall (P into SP); on D1 or the blank it makes none. D1, D0, P and S1 never become walls by a carry.
-
Base: w has no wall. Its units are D0, D1, P and S1. Each forwards at most one carry (D1, P) or stops it (D0, S1). So an arrival is one upward path of at most n + 1 unit steps, and the top step appends a D1. inc(w) is in L_gap and has no wall.
-
Step: w has walls. Write w = x · V · y, where V is the lowest wall and x is wall-free.
- The carry climbs x as in the base case. It stops in x, or it reaches V.
- If V = SP, it becomes W and the carry stops.
- If V = W, the row needs inc(y), inc(inc(y)) and inc³(y). Here y has fewer walls than w, so inc(y) is defined, lies in L_gap, and has no more walls than y (induction hypothesis).
- The same holds for inc(y) and then for inc²(y). These nested recursions are part of the recursion for inc(w), so they have no hit either.
- The shift then lands on D1 (making S1), on P (making SP) or on the blank. A hit is excluded by assumption.
- In every case inc(w) ∈ L_gap, and its wall count is at most that of w (item 1). ∎
A carry can leave a wall above the old top of the word. For example, one arrival on W W SP gives P SP P SP D0 D0 D1 (237 machine steps). The induction on walls needs no claim about that region. S3 checks the wall-count bound on every L_gap word it runs.
S3 also compares the machine and inc, cells and exact step counts, on every unit word of up to 4 units over 14 unit kinds, and on 20,000 random words with long P runs: 0 mismatches.
Corollary U′. Let w ∈ L_gap, and suppose no W firing inside the recursion for inc(w) is a hit. Then inc(w) is defined and inc(w) ∈ L_gap.
Proof. The L_gap rows produce only L_gap heads, except for the shift. A shift lands on D1 (giving S1), on P (giving SP), on the blank, or is a hit. Termination is Lemma U-term. ∎
So the machine halts only after a hit. The halting transition A1 is never used by any unit lemma: in every oracle proof, state A reads 0.
5FamilyCheck: related machines are killed together or have a reason to be left open.
No related machine found (no parent link, table twin, follow-on row or mention).
6ChecklistCheck: every ✓ is computed; the two ○ are yours to decide; an amber ! is an optional check that did not finish.
- ✓Machine string exactthe .v literal == holdout list line 322 byte for byte
- ✓Statement is
~halts tm c0parsed from the .v and confirmed by check_kill (theorem_text, theorem_rocq) - ✓No axioms beyond baseline0 assumption(s); tools/assumptions_baseline.txt allows only functional_extensionality_dep
- ✓coqchk finished (optional)coqchk pass in 299.9 s
- ✓.v hash matches the checked hash.v = checked sha256 a4144ade7c58…; submission/ copy = checked sha256 a4144ade7c58…
- ✓No repo-local paths in the .vcomments name no path of ours (vendor/, machines/, tools/, rocq/, scripts/, reports/, atlas/, data/, journal/, /home/); busycoq's own
verify/X.vis fine: none in the .v or the submission/ copy - ✓Public write-up is cleantools/writeup_lint.py on
submission/proof.md: 0 error(s) - ○proof.md reviewed by Dennis (Checkpoint B)no Checkpoint B note from Dennis found
- notes.md L42: proof.md (2026-10-12, round-3 self-review), validated by check_proof.py S1-S12. Every lemma is proved; nothing in the informal argument is open. Next: Checkpoint B (Dennis), then the Rocq formalization (proof.md §10). Se
- notes.md L608: **Still open (not informal-proof work).** Dennis's Checkpoint B read of proof.md. The Rocq formalization (proof.md §10) is large: zone layer with Lemma L/L′ as two-run statements and about 68,000 vm_compute representativ
- notes.md L634: **Next.** Dennis's Checkpoint B read (non-blocking), then the Rocq formalization (proof.md §10, smaller split).
- notes.md L641: - Not done: Discord post and upstream PR (Dennis's call). Checkpoint B notes: none on file at packaging time. Previous status.json saved as rocq/status_before_done.json.
- proof.md L10: - **Not yet done**: Dennis's Checkpoint B read, and the Rocq formalization (§10).
- proof.md L819: **What is still open.** Nothing in the informal argument. The next steps are Dennis's Checkpoint B read and the Rocq formalization (§10).
- ○Family posted together?no other kill in the family
Generated by tools/killreview.py at 2026-10-16 13:29 PDT in 0.1 s from the files linked above; nothing in this review is hand-written except the box “How we proved it never halts” (above), which quotes how_proved.md. Re-run: python3 -B tools/killreview.py 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB
Files
machines/<tm>/: 17 entries · raw notes, status, scripts, images
| name | size | changed |
|---|---|---|
| notes.md ↓ | 78 KB | 2026-10-13 05:11 |
| proof.md ↓ | 92 KB | 2026-10-13 00:46 |
| how_proved.md ↓ | 1.7 KB | 2026-10-14 10:51 |
| status.json ↓ | 1.8 KB | 2026-10-13 05:11 |
| observe.json ↓ | 15 KB | 2026-10-12 23:25 |
| deepen.json ↓ | 34 KB | 2026-10-12 23:28 |
| 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v ↓ | 206 KB | 2026-10-13 04:34 |
| decisions/ | 7 items | 2026-10-12 23:26 |
| img/ | 9 items | 2026-10-12 23:25 |
| rocq/ | 13 items | 2026-10-13 05:10 |
| scripts/ | 20 items | 2026-10-12 23:37 |
| submission/ | 5 items | 2026-10-13 05:11 |
| cfg_step1139175_pos-97.txt ↓ | 707 B | 2026-10-10 00:36 |
| check_proof.py ↓ | 44 KB | 2026-10-13 00:29 |
| phaseview.py ↓ | 4.6 KB | 2026-10-10 01:52 |
| validate_cycle.py ↓ | 2.6 KB | 2026-10-10 00:32 |
| validate_rules.py ↓ | 3.5 KB | 2026-10-10 00:28 |
status.json in full
{
"status": "KILLED_NONHALT",
"stage": "done",
"updated": "2026-10-13",
"reason": "check_kill PASS, independently re-verified",
"tm": "1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB",
"label": "#14",
"confidence": "high",
"template": "none applies (nearest verify/CounterCmp_v1.v Module TM1 differs in 11 of 12 transitions); counter pattern of verify/Example.v only",
"family_note": "Singleton group in data/holdouts/2026-10-07_eqv_1590.txt; 740 line 301, 778 line 322; sheet Results row 842 (class Structural counter + counter), no claim.",
"proof_md": "proof.md",
"kill": {
"file": "1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v",
"sha256": "a4144ade7c58e6c1ff15e9f905ed01bb0ec5c945e0ced0acc6cba043e050c65e",
"lines": 4422,
"check_kill": "PASS three times on the same sha256: round 4 (rocq/check_kill_r4.log, compile 317.9 s, coqchk 300.9 s), the independent auditor (compile 312.8 s, coqchk 299.6 s), and a fresh packaging run 2026-10-13T12:10:55Z (rocq/check_kill_submission.log: compile 315.6 s native, coqchk -norec pass 299.9 s under the 600 s cap, Print Assumptions closed, all 17 checks PASS)",
"assumptions": [],
"submission": "submission/",
"discord": "submission/discord.md, not posted (fill in <LINK>; search #bb6 first)"
},
"check_kill": {
"result": "PASS",
"mode": "nonhalt",
"sha256": "a4144ade7c58e6c1ff15e9f905ed01bb0ec5c945e0ced0acc6cba043e050c65e",
"compile_s": 317.95,
"coqchk": "pass",
"coqchk_s": 300.94,
"coqchk_cap_s": 600,
"assumptions": [],
"checked_at": "2026-10-13T11:44:47Z",
"log": "rocq/check_kill_r4.log"
},
"previous_status": {
"status": "KILLED_NONHALT",
"stage": "formalized",
"updated": "2026-10-13",
"reason": "check_kill PASS on the round-4 kill file (formalization round 4/4); not yet independently audited or packaged"
}
}observe.json contract (tools/README-card.md):
3 contract warnings
- diagrams: 7 (want 3-5)
- diagrams[5].window: not "cells A..B, 1 px = k cells"
- diagrams[6].window: not "cells A..B, 1 px = k cells"