Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Benoit Viguier
coq-verif-tweetnacl
Commits
78b09e76
Commit
78b09e76
authored
Jan 15, 2021
by
benoit
Browse files
fix
parent
510cad59
Changes
43
Expand all
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
78b09e76
...
...
@@ -17,6 +17,7 @@
.depend
.loadpath
_CoqProject
!packages/**/_CoqProject
*.cache
*~
*#
...
...
Makefile
0 → 100644
View file @
78b09e76
DIST
=
coq-verif-tweetnacl
# NO_COLOR="\033[0m"
# RED = "\033[38;5;009m"
# GREEN = "\033[38;5;010m"
# YELLOW = "\033[38;5;011m"
# ORANGE = "\033[38;5;214m"
# LIGHTPURPLE = "\033[38;5;177m"
# PURPLE = "\033[38;5;135m"
# CYAN = "\033[38;5;014m"
# LIGHTGRAY = "\033[38;5;252m"
# DARKGRAY = "\033[38;5;242m"
# BRIGHTRED = "\033[91m"
# BOLD = "\033[1m"
#
# all: coq-tweetnacl-spec coq-tweetnacl-vst
include
coq.mk
.PHONY
:
clean
clean
:
clean-spec clean-vst clean-dist
# build paper
.PHONY
:
paper
paper
:
@
cd
paper
&&
$(MAKE)
clean-paper
:
cd
paper
&&
$(MAKE)
clean
# generate artefact
$(DIST)
:
@
echo
$(BOLD)$(ORANGE)
"Creating
$(DIST)
"
$(NO_COLOR)$(DARKGRAY)
mkdir
$(DIST)
$(DIST)/specs_map.pdf
:
@
echo
$(BOLD)$(YELLOW)
"Building map for specs"
$(NO_COLOR)$(DARKGRAY)
cd
paper
&&
$(MAKE)
specs_map.pdf
mv
specs_map.pdf
$(DIST)
/specs_map.pdf
dist
:
clean-dist $(DIST) $(DIST)/specs_map.pdf
@
echo
$(BOLD)$(YELLOW)
"Preparing
$(DIST)
"
$(NO_COLOR)$(DARKGRAY)
cp
-r
proofs
$(DIST)
cd
$(DIST)
/proofs/spec
&&
$(MAKE)
clean
cd
$(DIST)
/proofs/vst
&&
$(MAKE)
clean
mkdir
$(DIST)
/packages
cp
-r
packages/coq-compcert
$(DIST)
/packages/
cp
-r
packages/coq-reciprocity
$(DIST)
/packages/
cp
-r
packages/coq-ssr-elliptic-curves
$(DIST)
/packages/
cp
-r
packages/coq-vst
$(DIST)
/packages/
cp
repo
$(DIST)
/
cp
version
$(DIST)
/
cp
README.md
$(DIST)
/
cp
coq.mk
$(DIST)
/Makefile
cp
opam
$(DIST)
/
@
echo
$(BOLD)$(LIGHTPURPLE)
"Building
$(DIST)
.tar.gz"
$(NO_COLOR)$(DARKGRAY)
tar
-czvf
$(DIST)
.tar.gz
$(DIST)
@
echo
$(BOLD)$(GREEN)
"Done."
$(NO_COLOR)
clean-dist
:
@
echo
$(BOLD)$(YELLOW)
"removing
$(DIST)
"
$(NO_COLOR)$(DARKGRAY)
-
rm
-r
$(DIST)
-
rm
$(DIST)
.tar.gz
@
echo
$(BOLD)$(GREEN)
"Done."
$(NO_COLOR)
packages/coq-bignums/coq-bignums.8.8.dev/.gitignore
0 → 100644
View file @
78b09e76
BigN/NMake_gen.v
*.d
*.o
*.cmi
*.cmx
*.cmxs
*.vo
*.glob
*.aux
Makefile.coq
Makefile.coq.conf
packages/coq-bignums/coq-bignums.8.8.dev/BigN/BigN.v
0 → 100644
View file @
78b09e76
(
************************************************************************
)
(
*
v
*
The
Coq
Proof
Assistant
/
The
Coq
Development
Team
*
)
(
*
<
O___
,,
*
INRIA
-
CNRS
-
LIX
-
LRI
-
PPS
-
Copyright
1999
-
2016
*
)
(
*
\
VV
/
**************************************************************
)
(
*
// * This file is distributed under the terms of the *)
(
*
*
GNU
Lesser
General
Public
License
Version
2.1
*
)
(
************************************************************************
)
(
**
*
Efficient
arbitrary
large
natural
numbers
in
base
2
^
31
*
)
(
**
Initial
Author
:
Arnaud
Spiwack
*
)
Require
Export
Int31
.
Require
Import
CyclicAxioms
Cyclic31
Ring31
NSig
NSigNAxioms
NMake
NProperties
GenericMinMax
.
(
**
The
following
[
BigN
]
module
regroups
both
the
operations
and
all
the
abstract
properties
:
-
[
NMake
.
Make
Int31Cyclic
]
provides
the
operations
and
basic
specs
w
.
r
.
t
.
ZArith
-
[
NTypeIsNAxioms
]
shows
(
mainly
)
that
these
operations
implement
the
interface
[
NAxioms
]
-
[
NProp
]
adds
all
generic
properties
derived
from
[
NAxioms
]
-
[
MinMax
*
Properties
]
provides
properties
of
[
min
]
and
[
max
].
*
)
Delimit
Scope
bigN_scope
with
bigN
.
Module
BigN
<:
NType
<:
OrderedTypeFull
<:
TotalOrder
:=
NMake
.
Make
Int31Cyclic
<+
NTypeIsNAxioms
<+
NBasicProp
[
no
inline
]
<+
NExtraProp
[
no
inline
]
<+
HasEqBool2Dec
[
no
inline
]
<+
MinMaxLogicalProperties
[
no
inline
]
<+
MinMaxDecProperties
[
no
inline
].
(
**
Notations
about
[
BigN
]
*
)
Local
Open
Scope
bigN_scope
.
Notation
bigN
:=
BigN
.
t
.
Bind
Scope
bigN_scope
with
bigN
BigN
.
t
BigN
.
t
'
.
Arguments
BigN
.
N0
_
%
int31
.
Local
Notation
"0"
:=
BigN
.
zero
:
bigN_scope
.
(
*
temporary
notation
*
)
Local
Notation
"1"
:=
BigN
.
one
:
bigN_scope
.
(
*
temporary
notation
*
)
Local
Notation
"2"
:=
BigN
.
two
:
bigN_scope
.
(
*
temporary
notation
*
)
Infix
"+"
:=
BigN
.
add
:
bigN_scope
.
Infix
"-"
:=
BigN
.
sub
:
bigN_scope
.
Infix
"*"
:=
BigN
.
mul
:
bigN_scope
.
Infix
"/"
:=
BigN
.
div
:
bigN_scope
.
Infix
"^"
:=
BigN
.
pow
:
bigN_scope
.
Infix
"?="
:=
BigN
.
compare
:
bigN_scope
.
Infix
"=?"
:=
BigN
.
eqb
(
at
level
70
,
no
associativity
)
:
bigN_scope
.
Infix
"<=?"
:=
BigN
.
leb
(
at
level
70
,
no
associativity
)
:
bigN_scope
.
Infix
"<?"
:=
BigN
.
ltb
(
at
level
70
,
no
associativity
)
:
bigN_scope
.
Infix
"=="
:=
BigN
.
eq
(
at
level
70
,
no
associativity
)
:
bigN_scope
.
Notation
"x != y"
:=
(
~
x
==
y
)
(
at
level
70
,
no
associativity
)
:
bigN_scope
.
Infix
"<"
:=
BigN
.
lt
:
bigN_scope
.
Infix
"<="
:=
BigN
.
le
:
bigN_scope
.
Notation
"x > y"
:=
(
y
<
x
)
(
only
parsing
)
:
bigN_scope
.
Notation
"x >= y"
:=
(
y
<=
x
)
(
only
parsing
)
:
bigN_scope
.
Notation
"x < y < z"
:=
(
x
<
y
/
\
y
<
z
)
:
bigN_scope
.
Notation
"x < y <= z"
:=
(
x
<
y
/
\
y
<=
z
)
:
bigN_scope
.
Notation
"x <= y < z"
:=
(
x
<=
y
/
\
y
<
z
)
:
bigN_scope
.
Notation
"x <= y <= z"
:=
(
x
<=
y
/
\
y
<=
z
)
:
bigN_scope
.
Notation
"[ i ]"
:=
(
BigN
.
to_Z
i
)
:
bigN_scope
.
Infix
"mod"
:=
BigN
.
modulo
(
at
level
40
,
no
associativity
)
:
bigN_scope
.
(
**
Example
of
reasoning
about
[
BigN
]
*
)
Theorem
succ_pred
:
forall
q
:
bigN
,
0
<
q
->
BigN
.
succ
(
BigN
.
pred
q
)
==
q
.
Proof
.
intros
;
apply
BigN
.
succ_pred
.
intro
H
'
;
rewrite
H
'
in
H
;
discriminate
.
Qed
.
(
**
[
BigN
]
is
a
semi
-
ring
*
)
Lemma
BigNring
:
semi_ring_theory
0
1
BigN
.
add
BigN
.
mul
BigN
.
eq
.
Proof
.
constructor
.
exact
BigN
.
add_0_l
.
exact
BigN
.
add_comm
.
exact
BigN
.
add_assoc
.
exact
BigN
.
mul_1_l
.
exact
BigN
.
mul_0_l
.
exact
BigN
.
mul_comm
.
exact
BigN
.
mul_assoc
.
exact
BigN
.
mul_add_distr_r
.
Qed
.
Lemma
BigNeqb_correct
:
forall
x
y
,
(
x
=?
y
)
=
true
->
x
==
y
.
Proof
.
now
apply
BigN
.
eqb_eq
.
Qed
.
Lemma
BigNpower
:
power_theory
1
BigN
.
mul
BigN
.
eq
BigN
.
of_N
BigN
.
pow
.
Proof
.
constructor
.
intros
.
red
.
rewrite
BigN
.
spec_pow
,
BigN
.
spec_of_N
.
rewrite
Zpower_theory
.(
rpow_pow_N
).
destruct
n
;
simpl
.
reflexivity
.
induction
p
;
simpl
;
intros
;
BigN
.
zify
;
rewrite
?
IHp
;
auto
.
Qed
.
Lemma
BigNdiv
:
div_theory
BigN
.
eq
BigN
.
add
BigN
.
mul
(
@
id
_
)
(
fun
a
b
=>
if
b
=?
0
then
(
0
,
a
)
else
BigN
.
div_eucl
a
b
).
Proof
.
constructor
.
unfold
id
.
intros
a
b
.
BigN
.
zify
.
case
Z
.
eqb_spec
.
BigN
.
zify
.
auto
with
zarith
.
intros
NEQ
.
generalize
(
BigN
.
spec_div_eucl
a
b
).
generalize
(
Z_div_mod_full
[
a
]
[
b
]
NEQ
).
destruct
BigN
.
div_eucl
as
(
q
,
r
),
Z
.
div_eucl
as
(
q
'
,
r
'
).
intros
(
EQ
,
_
).
injection
1
as
EQr
EQq
.
BigN
.
zify
.
rewrite
EQr
,
EQq
;
auto
.
Qed
.
(
**
Detection
of
constants
*
)
Ltac
isStaticWordCst
t
:=
match
t
with
|
W0
=>
constr
:
(
true
)
|
WW
?
t1
?
t2
=>
match
isStaticWordCst
t1
with
|
false
=>
constr
:
(
false
)
|
true
=>
isStaticWordCst
t2
end
|
_
=>
isInt31cst
t
end
.
Ltac
isBigNcst
t
:=
match
t
with
|
BigN
.
N0
?
t
=>
isStaticWordCst
t
|
BigN
.
N1
?
t
=>
isStaticWordCst
t
|
BigN
.
N2
?
t
=>
isStaticWordCst
t
|
BigN
.
N3
?
t
=>
isStaticWordCst
t
|
BigN
.
N4
?
t
=>
isStaticWordCst
t
|
BigN
.
N5
?
t
=>
isStaticWordCst
t
|
BigN
.
N6
?
t
=>
isStaticWordCst
t
|
BigN
.
Nn
?
n
?
t
=>
match
isnatcst
n
with
|
true
=>
isStaticWordCst
t
|
false
=>
constr
:
(
false
)
end
|
BigN
.
zero
=>
constr
:
(
true
)
|
BigN
.
one
=>
constr
:
(
true
)
|
BigN
.
two
=>
constr
:
(
true
)
|
_
=>
constr
:
(
false
)
end
.
Ltac
BigNcst
t
:=
match
isBigNcst
t
with
|
true
=>
constr
:
(
t
)
|
false
=>
constr
:
(
NotConstant
)
end
.
Ltac
BigN_to_N
t
:=
match
isBigNcst
t
with
|
true
=>
eval
vm_compute
in
(
BigN
.
to_N
t
)
|
false
=>
constr
:
(
NotConstant
)
end
.
Ltac
Ncst
t
:=
match
isNcst
t
with
|
true
=>
constr
:
(
t
)
|
false
=>
constr
:
(
NotConstant
)
end
.
(
**
Registration
for
the
"ring"
tactic
*
)
Add
Ring
BigNr
:
BigNring
(
decidable
BigNeqb_correct
,
constants
[
BigNcst
],
power_tac
BigNpower
[
BigN_to_N
],
div
BigNdiv
).
Section
TestRing
.
Let
test
:
forall
x
y
,
1
+
x
*
y
^
1
+
x
^
2
+
1
==
1
*
1
+
1
+
y
*
x
+
1
*
x
*
x
.
intros
.
ring_simplify
.
reflexivity
.
Qed
.
End
TestRing
.
(
**
We
benefit
also
from
an
"order"
tactic
*
)
Ltac
bigN_order
:=
BigN
.
order
.
Section
TestOrder
.
Let
test
:
forall
x
y
:
bigN
,
x
<=
y
->
y
<=
x
->
x
==
y
.
Proof
.
bigN_order
.
Qed
.
End
TestOrder
.
(
**
We
can
use
at
least
a
bit
of
(
r
)
omega
by
translating
to
[
Z
].
*
)
Section
TestOmega
.
Let
test
:
forall
x
y
:
bigN
,
x
<=
y
->
y
<=
x
->
x
==
y
.
Proof
.
intros
x
y
.
BigN
.
zify
.
omega
.
Qed
.
End
TestOmega
.
(
**
Todo
:
micromega
*
)
packages/coq-bignums/coq-bignums.8.8.dev/BigN/NMake.v
0 → 100644
View file @
78b09e76
This diff is collapsed.
Click to expand it.
packages/coq-bignums/coq-bignums.8.8.dev/BigN/NMake_gen.ml
0 → 100644
View file @
78b09e76
This diff is collapsed.
Click to expand it.
packages/coq-bignums/coq-bignums.8.8.dev/BigN/Nbasic.v
0 → 100644
View file @
78b09e76
(
************************************************************************
)
(
*
v
*
The
Coq
Proof
Assistant
/
The
Coq
Development
Team
*
)
(
*
<
O___
,,
*
INRIA
-
CNRS
-
LIX
-
LRI
-
PPS
-
Copyright
1999
-
2016
*
)
(
*
\
VV
/
**************************************************************
)
(
*
// * This file is distributed under the terms of the *)
(
*
*
GNU
Lesser
General
Public
License
Version
2.1
*
)
(
************************************************************************
)
(
*
Benjamin
Gregoire
,
Laurent
Thery
,
INRIA
,
2007
*
)
(
************************************************************************
)
Require
Import
ZArith
Ndigits
.
Require
Import
BigNumPrelude
.
Require
Import
Max
.
Require
Import
DoubleType
.
Require
Import
DoubleBase
.
Require
Import
CyclicAxioms
.
Require
Import
DoubleCyclic
.
Arguments
mk_zn2z_ops
[
t
]
ops
.
Arguments
mk_zn2z_ops_karatsuba
[
t
]
ops
.
Arguments
mk_zn2z_specs
[
t
ops
]
specs
.
Arguments
mk_zn2z_specs_karatsuba
[
t
ops
]
specs
.
Arguments
ZnZ
.
digits
[
t
]
Ops
.
Arguments
ZnZ
.
zdigits
[
t
]
Ops
.
Lemma
Pshiftl_nat_Zpower
:
forall
n
p
,
Zpos
(
Pos
.
shiftl_nat
p
n
)
=
Zpos
p
*
2
^
Z
.
of_nat
n
.
Proof
.
intros
.
rewrite
Z
.
mul_comm
.
induction
n
.
simpl
;
auto
.
transitivity
(
2
*
(
2
^
Z
.
of_nat
n
*
Zpos
p
)).
rewrite
<-
IHn
.
auto
.
rewrite
Z
.
mul_assoc
.
rewrite
Nat2Z
.
inj_succ
.
rewrite
<-
Z
.
pow_succ_r
;
auto
with
zarith
.
Qed
.
(
*
To
compute
the
necessary
height
*
)
Fixpoint
plength
(
p
:
positive
)
:
positive
:=
match
p
with
xH
=>
xH
|
xO
p1
=>
Pos
.
succ
(
plength
p1
)
|
xI
p1
=>
Pos
.
succ
(
plength
p1
)
end
.
Theorem
plength_correct
:
forall
p
,
(
Zpos
p
<
2
^
Zpos
(
plength
p
))
%
Z
.
assert
(
F
:
(
forall
p
,
2
^
(
Zpos
(
Pos
.
succ
p
))
=
2
*
2
^
Zpos
p
)
%
Z
).
intros
p
;
replace
(
Zpos
(
Pos
.
succ
p
))
with
(
1
+
Zpos
p
)
%
Z
.
rewrite
Zpower_exp
;
auto
with
zarith
.
rewrite
Pos2Z
.
inj_succ
;
unfold
Z
.
succ
;
auto
with
zarith
.
intros
p
;
elim
p
;
simpl
plength
;
auto
.
intros
p1
Hp1
;
rewrite
F
;
repeat
rewrite
Pos2Z
.
inj_xI
.
assert
(
tmp
:
(
forall
p
,
2
*
p
=
p
+
p
)
%
Z
);
try
repeat
rewrite
tmp
;
auto
with
zarith
.
intros
p1
Hp1
;
rewrite
F
;
rewrite
(
Pos2Z
.
inj_xO
p1
).
assert
(
tmp
:
(
forall
p
,
2
*
p
=
p
+
p
)
%
Z
);
try
repeat
rewrite
tmp
;
auto
with
zarith
.
rewrite
Z
.
pow_1_r
;
auto
with
zarith
.
Qed
.
Theorem
plength_pred_correct
:
forall
p
,
(
Zpos
p
<=
2
^
Zpos
(
plength
(
Pos
.
pred
p
)))
%
Z
.
intros
p
;
case
(
Pos
.
succ_pred_or
p
);
intros
H1
.
subst
;
simpl
plength
.
rewrite
Z
.
pow_1_r
;
auto
with
zarith
.
pattern
p
at
1
;
rewrite
<-
H1
.
rewrite
Pos2Z
.
inj_succ
;
unfold
Z
.
succ
;
auto
with
zarith
.
generalize
(
plength_correct
(
Pos
.
pred
p
));
auto
with
zarith
.
Qed
.
Definition
Pdiv
p
q
:=
match
Z
.
div
(
Zpos
p
)
(
Zpos
q
)
with
Zpos
q1
=>
match
(
Zpos
p
)
-
(
Zpos
q
)
*
(
Zpos
q1
)
with
Z0
=>
q1
|
_
=>
(
Pos
.
succ
q1
)
end
|
_
=>
xH
end
.
Theorem
Pdiv_le
:
forall
p
q
,
Zpos
p
<=
Zpos
q
*
Zpos
(
Pdiv
p
q
).
intros
p
q
.
unfold
Pdiv
.
assert
(
H1
:
Zpos
q
>
0
);
auto
with
zarith
.
assert
(
H1b
:
Zpos
p
>=
0
);
auto
with
zarith
.
generalize
(
Z_div_ge0
(
Zpos
p
)
(
Zpos
q
)
H1
H1b
).
generalize
(
Z_div_mod_eq
(
Zpos
p
)
(
Zpos
q
)
H1
);
case
Z
.
div
.
intros
HH
_
;
rewrite
HH
;
rewrite
Z
.
mul_0_r
;
rewrite
Z
.
mul_1_r
;
simpl
.
case
(
Z_mod_lt
(
Zpos
p
)
(
Zpos
q
)
H1
);
auto
with
zarith
.
intros
q1
H2
.
replace
(
Zpos
p
-
Zpos
q
*
Zpos
q1
)
with
(
Zpos
p
mod
Zpos
q
).
2
:
pattern
(
Zpos
p
)
at
2
;
rewrite
H2
;
auto
with
zarith
.
generalize
H2
(
Z_mod_lt
(
Zpos
p
)
(
Zpos
q
)
H1
);
clear
H2
;
case
Z
.
modulo
.
intros
HH
_
;
rewrite
HH
;
auto
with
zarith
.
intros
r1
HH
(
_
,
HH1
);
rewrite
HH
;
rewrite
Pos2Z
.
inj_succ
.
unfold
Z
.
succ
;
rewrite
Z
.
mul_add_distr_l
;
auto
with
zarith
.
intros
r1
_
(
HH
,
_
);
case
HH
;
auto
.
intros
q1
HH
;
rewrite
HH
.
unfold
Z
.
ge
;
simpl
Z
.
compare
;
intros
HH1
;
case
HH1
;
auto
.
Qed
.
Definition
is_one
p
:=
match
p
with
xH
=>
true
|
_
=>
false
end
.
Theorem
is_one_one
:
forall
p
,
is_one
p
=
true
->
p
=
xH
.
intros
p
;
case
p
;
auto
;
intros
p1
H1
;
discriminate
H1
.
Qed
.
Definition
get_height
digits
p
:=
let
r
:=
Pdiv
p
digits
in
if
is_one
r
then
xH
else
Pos
.
succ
(
plength
(
Pos
.
pred
r
)).
Theorem
get_height_correct
:
forall
digits
N
,
Zpos
N
<=
Zpos
digits
*
(
2
^
(
Zpos
(
get_height
digits
N
)
-
1
)).
intros
digits
N
.
unfold
get_height
.
assert
(
H1
:=
Pdiv_le
N
digits
).
case_eq
(
is_one
(
Pdiv
N
digits
));
intros
H2
.
rewrite
(
is_one_one
_
H2
)
in
H1
.
rewrite
Z
.
mul_1_r
in
H1
.
change
(
2
^
(
1
-
1
))
%
Z
with
1
;
rewrite
Z
.
mul_1_r
;
auto
.
clear
H2
.
apply
Z
.
le_trans
with
(
1
:=
H1
).
apply
Z
.
mul_le_mono_nonneg_l
;
auto
with
zarith
.
rewrite
Pos2Z
.
inj_succ
;
unfold
Z
.
succ
.
rewrite
Z
.
add_comm
;
rewrite
Z
.
add_simpl_l
.
apply
plength_pred_correct
.
Qed
.
Definition
zn2z_word_comm
:
forall
w
n
,
zn2z
(
word
w
n
)
=
word
(
zn2z
w
)
n
.
fix
zn2z_word_comm
2.
intros
w
n
;
case
n
.
reflexivity
.
intros
n0
;
simpl
.
case
(
zn2z_word_comm
w
n0
).
reflexivity
.
Defined
.
Fixpoint
extend
(
n
:
nat
)
{
struct
n
}
:
forall
w
:
Type
,
zn2z
w
->
word
w
(
S
n
)
:=
match
n
return
forall
w
:
Type
,
zn2z
w
->
word
w
(
S
n
)
with
|
O
=>
fun
w
x
=>
x
|
S
m
=>
let
aux
:=
extend
m
in
fun
w
x
=>
WW
W0
(
aux
w
x
)
end
.
Section
ExtendMax
.
Open
Scope
nat_scope
.
Fixpoint
plusnS
(
n
m
:
nat
)
{
struct
n
}
:
(
n
+
S
m
=
S
(
n
+
m
))
%
nat
:=
match
n
return
(
n
+
S
m
=
S
(
n
+
m
))
%
nat
with
|
0
=>
eq_refl
(
S
m
)
|
S
n1
=>
let
v
:=
S
(
S
n1
+
m
)
in
eq_ind_r
(
fun
n
=>
S
n
=
v
)
(
eq_refl
v
)
(
plusnS
n1
m
)
end
.
Fixpoint
plusn0
n
:
n
+
0
=
n
:=
match
n
return
(
n
+
0
=
n
)
with
|
0
=>
eq_refl
0
|
S
n1
=>
let
v
:=
S
n1
in
eq_ind_r
(
fun
n
:
nat
=>
S
n
=
v
)
(
eq_refl
v
)
(
plusn0
n1
)
end
.
Fixpoint
diff
(
m
n
:
nat
)
{
struct
m
}:
nat
*
nat
:=
match
m
,
n
with
O
,
n
=>
(
O
,
n
)
|
m
,
O
=>
(
m
,
O
)
|
S
m1
,
S
n1
=>
diff
m1
n1
end
.
Fixpoint
diff_l
(
m
n
:
nat
)
{
struct
m
}
:
fst
(
diff
m
n
)
+
n
=
max
m
n
:=
match
m
return
fst
(
diff
m
n
)
+
n
=
max
m
n
with
|
0
=>
match
n
return
(
n
=
max
0
n
)
with
|
0
=>
eq_refl
_
|
S
n0
=>
eq_refl
_
end
|
S
m1
=>
match
n
return
(
fst
(
diff
(
S
m1
)
n
)
+
n
=
max
(
S
m1
)
n
)
with
|
0
=>
plusn0
_
|
S
n1
=>
let
v
:=
fst
(
diff
m1
n1
)
+
n1
in
let
v1
:=
fst
(
diff
m1
n1
)
+
S
n1
in
eq_ind
v
(
fun
n
=>
v1
=
S
n
)
(
eq_ind
v1
(
fun
n
=>
v1
=
n
)
(
eq_refl
v1
)
(
S
v
)
(
plusnS
_
_
))
_
(
diff_l
_
_
)
end
end
.
Fixpoint
diff_r
(
m
n
:
nat
)
{
struct
m
}:
snd
(
diff
m
n
)
+
m
=
max
m
n
:=
match
m
return
(
snd
(
diff
m
n
)
+
m
=
max
m
n
)
with
|
0
=>
match
n
return
(
snd
(
diff
0
n
)
+
0
=
max
0
n
)
with
|
0
=>
eq_refl
_
|
S
_
=>
plusn0
_
end
|
S
m
=>
match
n
return
(
snd
(
diff
(
S
m
)
n
)
+
S
m
=
max
(
S
m
)
n
)
with
|
0
=>
eq_refl
(
snd
(
diff
(
S
m
)
0
)
+
S
m
)
|
S
n1
=>
let
v
:=
S
(
max
m
n1
)
in
eq_ind_r
(
fun
n
=>
n
=
v
)
(
eq_ind_r
(
fun
n
=>
S
n
=
v
)
(
eq_refl
v
)
(
diff_r
_
_
))
(
plusnS
_
_
)
end
end
.
Variable
w
:
Type
.
Definition
castm
(
m
n
:
nat
)
(
H
:
m
=
n
)
(
x
:
word
w
(
S
m
))
:
(
word
w
(
S
n
))
:=
match
H
in
(
_
=
y
)
return
(
word
w
(
S
y
))
with
|
eq_refl
=>
x
end
.
Variable
m
:
nat
.
Variable
v
:
(
word
w
(
S
m
)).
Fixpoint
extend_tr
(
n
:
nat
)
{
struct
n
}:
(
word
w
(
S
(
n
+
m
)))
:=
match
n
return
(
word
w
(
S
(
n
+
m
)))
with
|
O
=>
v
|
S
n1
=>
WW
W0
(
extend_tr
n1
)
end
.
End
ExtendMax
.
Arguments
extend_tr
[
w
m
]
v
n
.
Arguments
castm
[
w
m
n
]
H
x
.
Section
Reduce
.
Variable
w
:
Type
.
Variable
nT
:
Type
.
Variable
N0
:
nT
.
Variable
eq0
:
w
->
bool
.
Variable
reduce_n
:
w
->
nT
.
Variable
zn2z_to_Nt
:
zn2z
w
->
nT
.
Definition
reduce_n1
(
x
:
zn2z
w
)
:=
match
x
with
|
W0
=>
N0
|
WW
xh
xl
=>
if
eq0
xh
then
reduce_n
xl
else
zn2z_to_Nt
x
end
.
End
Reduce
.
Section
ReduceRec
.
Variable
w
:
Type
.
Variable
nT
:
Type
.
Variable
N0
:
nT
.
Variable
reduce_1n
:
zn2z
w
->
nT
.
Variable
c
:
forall
n
,
word
w
(
S
n
)
->
nT
.
Fixpoint
reduce_n
(
n
:
nat
)
:
word
w
(
S
n
)
->
nT
:=
match
n
return
word
w
(
S
n
)
->
nT
with
|
O
=>
reduce_1n
|
S
m
=>
fun
x
=>
match
x
with
|
W0
=>
N0
|
WW
xh
xl
=>
match
xh
with
|
W0
=>
@
reduce_n
m
xl
|
_
=>
@
c
(
S
m
)
x
end
end
end
.
End
ReduceRec
.
Section
CompareRec
.
Variable
wm
w
:
Type
.
Variable
w_0
:
w
.