diff --git a/Complex.v b/Complex.v index 089e8c5..59cd59f 100644 --- a/Complex.v +++ b/Complex.v @@ -304,6 +304,11 @@ Proof. apply injective_projections ; simpl ; ring. Qed. +<<<<<<< HEAD +======= + + +>>>>>>> Heisenberg-Foundations/main (* I'll be leaving out mixins and Canonical Structures : Definition C_AbelianGroup_mixin := AbelianGroup.Mixin _ _ _ _ Cplus_comm Cplus_assoc Cplus_0_r Cplus_opp_r. @@ -465,6 +470,7 @@ Proof. intros c. intros N E. apply N. rewrite E. reflexivity. Qed. Lemma RtoC_neq : forall (r : R), r <> 0 -> RtoC r <> 0. Proof. intros. apply C0_fst_neq. easy. Qed. +<<<<<<< HEAD Lemma Copp_neq_0_compat: forall c : C, c <> 0 -> (- c)%C <> 0. Proof. intros c H. @@ -477,6 +483,45 @@ Proof. assumption. Qed. +======= +Lemma C1_neq_C0 : C1 <> C0. +Proof. apply C0_fst_neq. + simpl. + apply R1_neq_R0. +Qed. + + +Lemma nonzero_div_nonzero : forall c : C, c <> C0 -> / c <> C0. +Proof. intros. + unfold not; intros. + assert (H' : (c * (/ c) = c * C0)%C). + { rewrite H0; easy. } + rewrite Cinv_r in H'; try easy. + rewrite Cmult_0_r in H'. + apply C1_neq_C0; easy. +Qed. + +Lemma eq_neg_implies_0 : forall (c : C), + (-C1 * c)%C = c -> c = C0. +Proof. intros. + assert (H' : (- C1 * c + c = c + c)%C). + { rewrite H; easy. } + assert (H'' : (- C1 * c + c = C0)%C). + { lca. } + rewrite H'' in H'. + assert (H0 : (c + c = C2 * c)%C). lca. + rewrite H0 in H'. + destruct (Ceq_dec c C0); try easy. + assert (H1 : C2 <> C0). + apply C0_fst_neq. + simpl. lra. + assert (H2 : (C2 * c)%C <> C0). + apply Cmult_neq_0; try easy. + rewrite <- H' in H2. easy. +Qed. + + +>>>>>>> Heisenberg-Foundations/main Lemma Cinv_mult_distr : forall c1 c2 : C, c1 <> 0 -> c2 <> 0 -> / (c1 * c2) = / c1 * / c2. Proof. intros. @@ -683,6 +728,7 @@ Proof. field. Qed. +<<<<<<< HEAD Lemma Cexp_plus_PI : forall x, Cexp (x + PI) = (- (Cexp x))%C. Proof. @@ -705,6 +751,8 @@ Proof. lca. Qed. +======= +>>>>>>> Heisenberg-Foundations/main Lemma Cexp_nonzero : forall θ, Cexp θ <> 0. Proof. intro θ. unfold Cexp. @@ -939,7 +987,11 @@ Qed. Hint Rewrite Cexp_0 Cexp_PI Cexp_PI2 Cexp_2PI Cexp_3PI2 Cexp_PI4 Cexp_PIm4 Cexp_1PI4 Cexp_2PI4 Cexp_3PI4 Cexp_4PI4 Cexp_5PI4 Cexp_6PI4 Cexp_7PI4 Cexp_8PI4 +<<<<<<< HEAD Cexp_add Cexp_neg Cexp_plus_PI Cexp_minus_PI : Cexp_db. +======= + Cexp_add Cexp_neg : Cexp_db. +>>>>>>> Heisenberg-Foundations/main Opaque C. @@ -953,6 +1005,7 @@ Lemma Cdiv_unfold : forall c1 c2, (c1 / c2 = c1 */ c2)%C. Proof. reflexivity. Qe (* For proving goals of the form x <> 0 or 0 < x *) Ltac nonzero := repeat split; +<<<<<<< HEAD repeat match goal with | |- not (@eq _ (Copp _) (RtoC (IZR Z0))) => apply Copp_neq_0_compat @@ -961,6 +1014,14 @@ Ltac nonzero := | |- not (@eq _ (Cexp _) (RtoC (IZR Z0))) => apply Cexp_nonzero | |- not (@eq _ _ (RtoC (IZR Z0))) => apply RtoC_neq end; +======= + try match goal with + | |- not (@eq _ _ (RtoC (IZR Z0))) => apply RtoC_neq + | |- not (@eq _ (Cpow _ _) (RtoC (IZR Z0))) => apply Cpow_nonzero; try apply RtoC_neq + | |- not (@eq _ Ci (RtoC (IZR Z0))) => apply C0_snd_neq; simpl + | |- not (@eq _ (Cexp _) (RtoC (IZR Z0))) => apply Cexp_nonzero + end; +>>>>>>> Heisenberg-Foundations/main repeat match goal with | |- not (@eq _ (sqrt (pow _ _)) (IZR Z0)) => rewrite sqrt_pow @@ -974,12 +1035,20 @@ Ltac nonzero := | |- Rlt (IZR Z0) (Rmult _ _) => apply Rmult_lt_0_compat | |- Rlt (IZR Z0) (Rinv _) => apply Rinv_0_lt_compat | |- Rlt (IZR Z0) (pow _ _) => apply pow_lt +<<<<<<< HEAD end; match goal with | |- not (@eq _ _ _) => lra | |- Rlt _ _ => lra | |- Rle _ _ => lra end. +======= + end; match goal with + | |- not (@eq _ _ _) => lra + | |- Rlt _ _ => lra + | |- Rle _ _ => lra + end. +>>>>>>> Heisenberg-Foundations/main Hint Rewrite Cminus_unfold Cdiv_unfold Ci2 Cconj_R Cconj_opp Cconj_rad2 Cinv_sqrt2_sqrt Cplus_div2 @@ -1000,9 +1069,12 @@ Hint Rewrite Cplus_0_l Cplus_0_r Cmult_0_l Cmult_0_r Copp_0 Hint Rewrite Cmult_plus_distr_l Cmult_plus_distr_r Copp_plus_distr Copp_mult_distr_l Copp_involutive : Cdist_db. +<<<<<<< HEAD Hint Rewrite <- RtoC_opp RtoC_mult RtoC_plus : RtoC_db. Hint Rewrite <- RtoC_inv using nonzero : RtoC_db. Hint Rewrite RtoC_pow : RtoC_db. +======= +>>>>>>> Heisenberg-Foundations/main Ltac Csimpl := repeat match goal with diff --git a/CoqMakefile b/CoqMakefile new file mode 100644 index 0000000..6440009 --- /dev/null +++ b/CoqMakefile @@ -0,0 +1,866 @@ +########################################################################## +## # The Coq Proof Assistant / The Coq Development Team ## +## v # Copyright INRIA, CNRS and contributors ## +## /dev/null 2>/dev/null; echo $$?)) +STDTIME?=command time -f $(TIMEFMT) +else +ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=gtime -f $(TIMEFMT) +else +STDTIME?=command time +endif +endif +else +STDTIME?=command time -f $(TIMEFMT) +endif + +ifneq (,$(COQBIN)) +# add an ending / +COQBIN:=$(COQBIN)/ +endif + +# Coq binaries +COQC ?= "$(COQBIN)coqc" +COQTOP ?= "$(COQBIN)coqtop" +COQCHK ?= "$(COQBIN)coqchk" +COQDEP ?= "$(COQBIN)coqdep" +COQDOC ?= "$(COQBIN)coqdoc" +COQPP ?= "$(COQBIN)coqpp" +COQMKFILE ?= "$(COQBIN)coq_makefile" +OCAMLLIBDEP ?= "$(COQBIN)ocamllibdep" + +# Timing scripts +COQMAKE_ONE_TIME_FILE ?= "$(COQLIB)/tools/make-one-time-file.py" +COQMAKE_BOTH_TIME_FILES ?= "$(COQLIB)/tools/make-both-time-files.py" +COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQLIB)/tools/make-both-single-timing-files.py" +BEFORE ?= +AFTER ?= + +# FIXME this should be generated by Coq (modules already linked by Coq) +CAMLDONTLINK=num,str,unix,dynlink,threads + +# OCaml binaries +CAMLC ?= "$(OCAMLFIND)" ocamlc -c +CAMLOPTC ?= "$(OCAMLFIND)" opt -c +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) +CAMLDOC ?= "$(OCAMLFIND)" ocamldoc +CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack + +# DESTDIR is prepended to all installation paths +DESTDIR ?= + +# Debug builds, typically -g to OCaml, -debug to Coq. +CAMLDEBUG ?= +COQDEBUG ?= + +# Extra packages to be linked in (as in findlib -package) +CAMLPKGS ?= + +# Option for making timing files +TIMING?= +# Option for changing sorting of timing output file +TIMING_SORT_BY ?= auto +# Option for changing the fuzz parameter on the output file +TIMING_FUZZ ?= 0 +# Option for changing whether to use real or user time for timing tables +TIMING_REAL?= +# Option for including the memory column(s) +TIMING_INCLUDE_MEM?= +# Option for sorting by the memory column +TIMING_SORT_BY_MEM?= +# Output file names for timed builds +TIME_OF_BUILD_FILE ?= time-of-build.log +TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log +TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log +TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log +TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log +TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line + +TGTS ?= + +########## End of parameters ################################################## +# What follows may be relevant to you only if you need to +# extend this Makefile. If so, look for 'Extension point' here and +# put in CoqMakefile.local double colon rules accordingly. +# E.g. to perform some work after the all target completes you can write +# +# post-all:: +# echo "All done!" +# +# in CoqMakefile.local +# +############################################################################### + + + + +# Flags ####################################################################### +# +# We define a bunch of variables combining the parameters. +# To add additional flags to coq, coqchk or coqdoc, set the +# {COQ,COQCHK,COQDOC}EXTRAFLAGS variable to whatever you want to add. +# To overwrite the default choice and set your own flags entirely, set the +# {COQ,COQCHK,COQDOC}FLAGS variable. + +SHOW := $(if $(VERBOSE),@true "",@echo "") +HIDE := $(if $(VERBOSE),,@) + +TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) + +OPT?= + +# The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d +ifeq '$(OPT)' '-byte' +USEBYTE:=true +DYNOBJ:=.cma +DYNLIB:=.cma +else +USEBYTE:= +DYNOBJ:=.cmxs +DYNLIB:=.cmxs +endif + +# these variables are meant to be overridden if you want to add *extra* flags +COQEXTRAFLAGS?= +COQCHKEXTRAFLAGS?= +COQDOCEXTRAFLAGS?= + +# these flags do NOT contain the libraries, to make them easier to overwrite +COQFLAGS?=-q $(OTHERFLAGS) $(COQEXTRAFLAGS) +COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) +COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) + +COQDOCLIBS?=$(COQLIBS_NOML) + +# The version of Coq being run and the version of coq_makefile that +# generated this makefile +COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) +COQMAKEFILE_VERSION:=8.12.2 + +COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") + +CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) +# ocamldoc fails with unknown argument otherwise +CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) +CAMLFLAGS+=$(OCAMLWARN) + +ifneq (,$(TIMING)) +TIMING_ARG=-time +ifeq (after,$(TIMING)) +TIMING_EXT=after-timing +else +ifeq (before,$(TIMING)) +TIMING_EXT=before-timing +else +TIMING_EXT=timing +endif +endif +else +TIMING_ARG= +endif + +# Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) +ifdef DSTROOT +DESTDIR := $(DSTROOT) +endif + +concat_path = $(if $(1),$(1)/$(if $(COQMF_WINDRIVE),$(subst $(COQMF_WINDRIVE),/,$(2)),$(2)),$(2)) + +COQLIBINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)/user-contrib) +COQDOCINSTALL = $(call concat_path,$(DESTDIR),$(DOCDIR)/user-contrib) +COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)/toploop) + +# Files ####################################################################### +# +# We here define a bunch of variables about the files being part of the +# Coq project in order to ease the writing of build target and build rules + +VDFILE := .CoqMakefile.d + +ALLSRCFILES := \ + $(MLGFILES) \ + $(MLFILES) \ + $(MLPACKFILES) \ + $(MLLIBFILES) \ + $(MLIFILES) + +# helpers +vo_to_obj = $(addsuffix .o,\ + $(filter-out Warning: Error:,\ + $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) +strip_dotslash = $(patsubst ./%,%,$(1)) + +# without this we get undefined variables in the expansion for the +# targets of the [deprecated,use-mllib-or-mlpack] rule +with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) + +VO = vo +VOS = vos + +VOFILES = $(VFILES:.v=.$(VO)) +GLOBFILES = $(VFILES:.v=.glob) +HTMLFILES = $(VFILES:.v=.html) +GHTMLFILES = $(VFILES:.v=.g.html) +BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) +TEXFILES = $(VFILES:.v=.tex) +GTEXFILES = $(VFILES:.v=.g.tex) +CMOFILES = \ + $(MLGFILES:.mlg=.cmo) \ + $(MLFILES:.ml=.cmo) \ + $(MLPACKFILES:.mlpack=.cmo) +CMXFILES = $(CMOFILES:.cmo=.cmx) +OFILES = $(CMXFILES:.cmx=.o) +CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) +CMXAFILES = $(CMAFILES:.cma=.cmxa) +CMIFILES = \ + $(CMOFILES:.cmo=.cmi) \ + $(MLIFILES:.mli=.cmi) +# the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just +# a .mlg file +CMXSFILES = \ + $(MLPACKFILES:.mlpack=.cmxs) \ + $(CMXAFILES:.cmxa=.cmxs) \ + $(if $(MLPACKFILES)$(CMXAFILES),,\ + $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) + +# files that are packed into a plugin (no extension) +PACKEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) +# files that are archived into a .cma (mllib) +LIBEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) +CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) +CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) +OBJFILES = $(call vo_to_obj,$(VOFILES)) +ALLNATIVEFILES = \ + $(OBJFILES:.o=.cmi) \ + $(OBJFILES:.o=.cmx) \ + $(OBJFILES:.o=.cmxs) +# trick: wildcard filters out non-existing files, so that `install` doesn't show +# warnings and `clean` doesn't pass to rm a list of files that is too long for +# the shell. +NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) +FILESTOINSTALL = \ + $(VOFILES) \ + $(VFILES) \ + $(GLOBFILES) \ + $(NATIVEFILES) \ + $(CMIFILESTOINSTALL) +BYTEFILESTOINSTALL = \ + $(CMOFILESTOINSTALL) \ + $(CMAFILES) +ifeq '$(HASNATDYNLINK)' 'true' +DO_NATDYNLINK = yes +FILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) +else +DO_NATDYNLINK = +endif + +ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) $(VDFILE) + +# Compilation targets ######################################################### + +all: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all + +all.timing.diff: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all.timing.diff + +ifeq (0,$(TIMING_REAL)) +TIMING_REAL_ARG := +TIMING_USER_ARG := --user +else +ifeq (1,$(TIMING_REAL)) +TIMING_REAL_ARG := --real +TIMING_USER_ARG := +else +TIMING_REAL_ARG := +TIMING_USER_ARG := +endif +endif + +ifeq (0,$(TIMING_INCLUDE_MEM)) +TIMING_INCLUDE_MEM_ARG := --no-include-mem +else +TIMING_INCLUDE_MEM_ARG := +endif + +ifeq (1,$(TIMING_SORT_BY_MEM)) +TIMING_SORT_BY_MEM_ARG := --sort-by-mem +else +TIMING_SORT_BY_MEM_ARG := +endif + +make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) +make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) +make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) + $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed +print-pretty-timed:: + $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +print-pretty-timed-diff:: + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +ifeq (,$(BEFORE)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' + $(HIDE)false +else +ifeq (,$(AFTER)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' + $(HIDE)false +else +print-pretty-single-time-diff:: + $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --fuzz=$(TIMING_FUZZ) --sort-by=$(TIMING_SORT_BY) $(TIMING_USER_ARG) $(AFTER) $(BEFORE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +endif +endif +pretty-timed: + $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed +.PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff + +# Extension points for actions to be performed before/after the all target +pre-all:: + @# Extension point + $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ + echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ + echo "W: while the current Coq version is $(COQ_VERSION)";\ + fi +.PHONY: pre-all + +post-all:: + @# Extension point +.PHONY: post-all + +real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) +.PHONY: real-all + +real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) +.PHONY: real-all.timing.diff + +bytefiles: $(CMOFILES) $(CMAFILES) +.PHONY: bytefiles + +optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) +.PHONY: optfiles + +# FIXME, see Ralf's bugreport +# quick is deprecated, now renamed vio +vio: $(VOFILES:.vo=.vio) +.PHONY: vio +quick: vio + $(warning "'make quick' is deprecated, use 'make vio' or consider using 'vos' files") +.PHONY: quick + +vio2vo: + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ + -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) +.PHONY: vio2vo + +# quick2vo is undocumented +quick2vo: + $(HIDE)make -j $(J) vio + $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ + viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ + if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ + done); \ + echo "VIO2VO: $$VIOFILES"; \ + if [ -n "$$VIOFILES" ]; then \ + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -schedule-vio2vo $(J) $$VIOFILES; \ + fi +.PHONY: quick2vo + +checkproofs: + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ + -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) +.PHONY: checkproofs + +vos: $(VOFILES:%.vo=%.vos) +.PHONY: vos + +vok: $(VOFILES:%.vo=%.vok) +.PHONY: vok + +validate: $(VOFILES) + $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $^ +.PHONY: validate + +only: $(TGTS) +.PHONY: only + +# Documentation targets ####################################################### + +html: $(GLOBFILES) $(VFILES) + $(SHOW)'COQDOC -d html $(GAL)' + $(HIDE)mkdir -p html + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) + +mlihtml: $(MLIFILES:.mli=.cmi) + $(SHOW)'CAMLDOC -d $@' + $(HIDE)mkdir $@ || rm -rf $@/* + $(HIDE)$(CAMLDOC) -html \ + -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) + +all-mli.tex: $(MLIFILES:.mli=.cmi) + $(SHOW)'CAMLDOC -latex $@' + $(HIDE)$(CAMLDOC) -latex \ + -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) + +all.ps: $(VFILES) + $(SHOW)'COQDOC -ps $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort $(VFILES)` + +all.pdf: $(VFILES) + $(SHOW)'COQDOC -pdf $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort $(VFILES)` + +# FIXME: not quite right, since the output name is different +gallinahtml: GAL=-g +gallinahtml: html + +all-gal.ps: GAL=-g +all-gal.ps: all.ps + +all-gal.pdf: GAL=-g +all-gal.pdf: all.pdf + +# ? +beautify: $(BEAUTYFILES) + for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done + @echo 'Do not do "make clean" until you are sure that everything went well!' + @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' +.PHONY: beautify + +# Installation targets ######################################################## +# +# There rules can be extended in CoqMakefile.local +# Extensions can't assume when they run. + +install: + $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ + if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ + done; exit $$code + $(HIDE)for f in $(FILESTOINSTALL); do\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ + echo SKIP "$$f" since it has no logical path;\ + else\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ + fi;\ + done + $(HIDE)$(MAKE) install-extra -f "$(SELF)" +install-extra:: + @# Extension point +.PHONY: install install-extra + +install-byte: + $(HIDE)for f in $(BYTEFILESTOINSTALL); do\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ + echo SKIP "$$f" since it has no logical path;\ + else\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ + fi;\ + done + +install-doc:: html mlihtml + @# Extension point + $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(HIDE)for i in html/*; do \ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done + $(HIDE)install -d \ + "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE)for i in mlihtml/*; do \ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done +.PHONY: install-doc + +uninstall:: + @# Extension point + $(HIDE)for f in $(FILESTOINSTALL); do \ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ + instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ + rm -f "$$instf" &&\ + echo RM "$$instf" &&\ + (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" 2>/dev/null || true); \ + done +.PHONY: uninstall + +uninstall-doc:: + @# Extension point + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true +.PHONY: uninstall-doc + +# Cleaning #################################################################### +# +# There rules can be extended in CoqMakefile.local +# Extensions can't assume when they run. + +clean:: + @# Extension point + $(SHOW)'CLEAN' + $(HIDE)rm -f $(CMOFILES) + $(HIDE)rm -f $(CMIFILES) + $(HIDE)rm -f $(CMAFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.cmx) + $(HIDE)rm -f $(CMXAFILES) + $(HIDE)rm -f $(CMXSFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.o) + $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) + $(HIDE)rm -f $(MLGFILES:.mlg=.ml) + $(HIDE)rm -f $(ALLDFILES) + $(HIDE)rm -f $(NATIVEFILES) + $(HIDE)find . -name .coq-native -type d -empty -delete + $(HIDE)rm -f $(VOFILES) + $(HIDE)rm -f $(VOFILES:.vo=.vio) + $(HIDE)rm -f $(VOFILES:.vo=.vos) + $(HIDE)rm -f $(VOFILES:.vo=.vok) + $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) + $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex + $(HIDE)rm -f $(VFILES:.v=.glob) + $(HIDE)rm -f $(VFILES:.v=.tex) + $(HIDE)rm -f $(VFILES:.v=.g.tex) + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)rm -rf html mlihtml +.PHONY: clean + +cleanall:: clean + @# Extension point + $(SHOW)'CLEAN *.aux *.timing' + $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) + $(HIDE)rm -f $(TIME_OF_BUILD_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) + $(HIDE)rm -f .lia.cache .nia.cache +.PHONY: cleanall + +archclean:: + @# Extension point + $(SHOW)'CLEAN *.cmx *.o' + $(HIDE)rm -f $(NATIVEFILES) + $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) +.PHONY: archclean + + +# Compilation rules ########################################################### + +$(MLIFILES:.mli=.cmi): %.cmi: %.mli + $(SHOW)'CAMLC -c $<' + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + +$(MLGFILES:.mlg=.ml): %.ml: %.mlg + $(SHOW)'COQPP $<' + $(HIDE)$(COQPP) $< + +# Stupid hack around a deficient syntax: we cannot concatenate two expansions +$(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml + $(SHOW)'CAMLC -c $<' + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + +# Same hack +$(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml + $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' + $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< + + +$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -linkall -shared -o $@ $< + +$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + +$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + + +$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -shared -linkall -o $@ $< + +$(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< + +$(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack + $(SHOW)'CAMLC -pack -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack + $(SHOW)'CAMLOPT -pack -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + +# This rule is for _CoqProject with no .mllib nor .mlpack +$(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx + $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -shared -o $@ $< + +ifneq (,$(TIMING)) +TIMING_EXTRA = > $<.$(TIMING_EXT) +else +TIMING_EXTRA = +endif + +$(VOFILES): %.vo: %.v + $(SHOW)COQC $< + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) + +# FIXME ?merge with .vo / .vio ? +$(GLOBFILES): %.glob: %.v + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vio): %.vio: %.v + $(SHOW)COQC -vio $< + $(HIDE)$(TIMER) $(COQC) -vio $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vos): %.vos: %.v + $(SHOW)COQC -vos $< + $(HIDE)$(TIMER) $(COQC) -vos $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vok): %.vok: %.v + $(SHOW)COQC -vok $< + $(HIDE)$(TIMER) $(COQC) -vok $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing + $(SHOW)PYTHON TIMING-DIFF $*.{before,after}-timing + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" + +$(BEAUTYFILES): %.v.beautified: %.v + $(SHOW)'BEAUTIFY $<' + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -beautify $< + +$(TEXFILES): %.tex: %.v + $(SHOW)'COQDOC -latex $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ + +$(GTEXFILES): %.g.tex: %.v + $(SHOW)'COQDOC -latex -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ + +$(HTMLFILES): %.html: %.v %.glob + $(SHOW)'COQDOC -html $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ + +$(GHTMLFILES): %.g.html: %.v %.glob + $(SHOW)'COQDOC -html -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ + +# Dependency files ############################################################ + +ifndef MAKECMDGOALS + -include $(ALLDFILES) +else + ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) + -include $(ALLDFILES) + endif +endif + +.SECONDARY: $(ALLDFILES) + +redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) + +GENMLFILES:=$(MLGFILES:.mlg=.ml) +$(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) + +$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLGFILES)): %.mlg.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib + $(SHOW)'OCAMLLIBDEP $<' + $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack + $(SHOW)'OCAMLLIBDEP $<' + $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) + +# If this makefile is created using a _CoqProject we have coqdep get +# options from it. This avoids argument length limits for pathological +# projects. Note that extra options might be on the command line. +VDFILE_FLAGS:=$(if _CoqProject,-f _CoqProject,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) + +$(VDFILE): $(VFILES) + $(SHOW)'COQDEP VFILES' + $(HIDE)$(COQDEP) -vos -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) + +# Misc ######################################################################## + +byte: + $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" +.PHONY: byte + +opt: + $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" +.PHONY: opt + +# This is deprecated. To extend this makefile use +# extension points and CoqMakefile.local +printenv:: + $(warning printenv is deprecated) + $(warning write extensions in CoqMakefile.local or include CoqMakefile.conf) + @echo 'LOCAL = $(LOCAL)' + @echo 'COQLIB = $(COQLIB)' + @echo 'DOCDIR = $(DOCDIR)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' + @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' + @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'PP = $(PP)' + @echo 'COQFLAGS = $(COQFLAGS)' + @echo 'COQLIB = $(COQLIBS)' + @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' + @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' +.PHONY: printenv + +# Generate a .merlin file. If you need to append directives to this +# file you can extend the merlin-hook target in CoqMakefile.local +.merlin: + $(SHOW)'FILL .merlin' + $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin + $(HIDE)echo 'B $(COQLIB)' >> .merlin + $(HIDE)echo 'S $(COQLIB)' >> .merlin + $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ + echo 'B $(COQLIB)$(d)' >> .merlin;) + $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ + echo 'S $(COQLIB)$(d)' >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) + $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" +.PHONY: merlin + +merlin-hook:: + @# Extension point +.PHONY: merlin-hook + +# prints all variables +debug: + $(foreach v,\ + $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ + $(.VARIABLES))),\ + $(info $(v) = $($(v)))) +.PHONY: debug + +.DEFAULT_GOAL := all + +# Local Variables: +# mode: makefile-gmake +# End: diff --git a/Eigenvectors.v b/Eigenvectors.v new file mode 100644 index 0000000..190d3f8 --- /dev/null +++ b/Eigenvectors.v @@ -0,0 +1,3214 @@ +Require Import List. +Require Export Complex. +Require Export Matrix. +Require Export Quantum. +Require Export Polynomial. + + +(* Some preliminary lemmas/additions to tactics that could be moved to other files *) + + +Local Open Scope nat_scope. + + +(* where can I find tactics to deal with this??? *) +Lemma easy_sub3 : forall (n k : nat), n <> 0 -> n + k - 0 - 1 = n - 0 - 1 + k. +Proof. intros. + destruct n as [| n]. + - easy. + - simpl. lia. +Qed. + +Lemma easy_sub6 : forall (a c b : nat), + b < c -> a < b -> c = (a + S (b - a) + (c - b - 1)). +Proof. intros. lia. Qed. + + + + +Lemma easy_pow : forall (a n m : nat), a^(n + m) = a^n * a^m. +Proof. intros. induction n as [| n']. + - simpl. nia. + - simpl. rewrite IHn'. nia. +Qed. +Lemma easy_pow2 : forall (a p : nat), p <> 0 -> a^p = a * a ^ (p - 0 - 1). +Proof. intros. destruct p as [| p']. easy. simpl. + rewrite Nat.sub_0_r. easy. +Qed. +Lemma easy_pow3 : forall (n m : nat), m < n -> 2^n = (2^m) * 2 * 2^(n - m - 1). +Proof. intros. + assert (H' : 2^m * 2 = 2^(m + 1)). + { rewrite easy_pow. reflexivity. } + rewrite H'. + rewrite <- easy_pow. + assert (H'' : m < n -> m + 1 + (n - m - 1) = n). + { nia. } + rewrite H''. + reflexivity. + assumption. +Qed. +Lemma easy_pow4 : forall (n : nat), (0 >= 2^n) -> False. +Proof. intros. induction n as [| n']. + - simpl in *. nia. + - simpl in *. + assert (H' : forall (a : nat), a + 0 = a). { nia. } + rewrite H' in H. + assert (H'' : forall (a : nat), a + a >= a). { nia. } + apply IHn'. + nia. +Qed. +Lemma easy_pow5 : forall (a b c : nat), + b < c -> a < b -> + 2^c = (2^a * (2^(b - a) + (2^(b - a) + 0))) * 2^(c - b - 1). +Proof. intros. + assert (H' : forall n, 2^n + (2^n + 0) = 2^(S n)). + { reflexivity. } + rewrite H'. + do 2 (rewrite <- easy_pow). + rewrite <- (easy_sub6 a c b); try easy. +Qed. +Lemma easy_pow5' : forall (a b c : nat), + b < c -> a < b -> + 2^c = (2^a * (2^(b - a) * 2)) * 2^(c - b - 1). +Proof. intros. + assert (H' : 2 ^ (b - a) * 2 = 2 ^ (b - a) * 2^1). + { reflexivity. } + rewrite H'. + do 3 (rewrite <- easy_pow). + assert (H'' : b - a + 1 = S (b - a)). { nia. } + rewrite H''. + rewrite <- (easy_sub6 a c b); try easy. +Qed. +Lemma easy_pow6 : forall (n : nat), n <> 0 -> 2*2^n = (2*2^(n-1))*2. +Proof. destruct n. + - easy. + - intros. + simpl. + replace (n - 0) with n by lia. + nia. +Qed. + +Lemma easy_pow6' : forall (n : nat), n <> 0 -> (2^n)*2 = (2*2^(n-1))*2. +Proof. intros. rewrite mult_comm. + apply easy_pow6; easy. +Qed. + + + +(*************************) +(* Some basic list stuff *) +(*************************) + + +Definition zipWith {X Y Z: Type} (f : X -> Y -> Z) (As : list X) (Bs : list Y) : list Z := + map (uncurry f) (combine As Bs). + + +Lemma zipWith_len_pres : forall {X Y Z : Type} (f : X -> Y -> Z) (n : nat) + (As : list X) (Bs : list Y), + length As = n -> length Bs = n -> length (zipWith f As Bs) = n. +Proof. intros. + unfold zipWith. + rewrite map_length. + rewrite combine_length. + rewrite H, H0; lia. +Qed. + + +Lemma zipWith_app_product : forall {X Y Z: Type} (f : X -> Y -> Z) (n : nat) + (l0s l2s : list X) (l1s l3s : list Y), + length l0s = n -> length l1s = n -> + (zipWith f l0s l1s) ++ (zipWith f l2s l3s) = zipWith f (l0s ++ l2s) (l1s ++ l3s). +Proof. induction n as [| n']. + - intros. destruct l0s; destruct l1s; easy. + - intros. destruct l0s; destruct l1s; try easy. + unfold zipWith in *. + simpl in *. + rewrite <- IHn'; try nia. + reflexivity. +Qed. + + +Lemma zipWith_cons : forall {X Y Z : Type} (f : X -> Y -> Z) (a : X) (b : Y) (A : list X) (B : list Y), + zipWith f (a :: A) (b :: B) = (f a b) :: (zipWith f A B). +Proof. intros. + unfold zipWith. simpl. + unfold uncurry. + simpl. easy. +Qed. + + +Fixpoint first_n (n : nat) : list nat := + match n with + | 0 => [0] + | S n' => n :: first_n n' + end. + +Lemma first_n_contains : forall (n i : nat), + i <= n <-> In i (first_n n). +Proof. split. + - induction n as [| n']. + * intros. bdestruct (i =? 0). + + rewrite H0. simpl. left. easy. + + apply le_n_0_eq in H. rewrite H in H0. easy. + * intros. simpl. bdestruct (i =? S n'). + + left. rewrite H0. easy. + + right. apply IHn'. + apply le_lt_eq_dec in H. destruct H. + ** apply Nat.lt_succ_r. apply l. + ** rewrite e in H0. easy. + - induction n as [| n']. + * intros [H | F]. + + rewrite H. easy. + + simpl in F. easy. + * intros. simpl in H. destruct H. + + rewrite H. easy. + + apply IHn' in H. + apply le_n_S in H. apply le_Sn_le. + apply H. +Qed. + + +(* defining switch and many lemmas having to do with switch and nth *) + +Fixpoint switch {X : Type} (ls : list X) (x : X) (n : nat) := + match ls with + | [] => [] + | (h :: ls') => + match n with + | 0 => x :: ls' + | S n' => h :: (switch ls' x n') + end + end. + +Lemma switch_len : forall {X : Type} (n : nat) (ls : list X) (x : X), + length (switch ls x n) = length ls. +Proof. induction n as [| n']. + - destruct ls. easy. easy. + - intros. destruct ls. + easy. simpl. + rewrite IHn'. + reflexivity. +Qed. + + +Lemma switch_map : forall {X Y : Type} (n : nat) (ls : list X) (x : X) (f : X -> Y), + map f (switch ls x n) = switch (map f ls) (f x) n. +Proof. induction n as [| n']. + - intros. destruct ls; easy. + - intros. destruct ls. easy. + simpl. rewrite IHn'. easy. +Qed. + +Lemma switch_switch_diff : forall {X : Type} (n m : nat) (ls : list X) (a b : X), + n <> m -> + switch (switch ls a n) b m = switch (switch ls b m) a n. +Proof. induction n as [| n']. + - intros. + destruct m; destruct ls; easy. + - intros. + destruct m; try (destruct ls; easy). + destruct ls; try easy. + simpl. + rewrite IHn'; try easy. + bdestruct (n' =? m); lia. +Qed. + +Lemma switch_base : forall {X : Type} (ls : list X) (x : X), + ls <> [] -> switch ls x 0 = x :: (skipn 1 ls). +Proof. intros. + destruct ls. + easy. + reflexivity. +Qed. + + + +Lemma nth_switch_hit : forall {X : Type} (n : nat) (ls : list X) (x def : X), + n < length ls -> + nth n (switch ls x n) def = x. +Proof. induction n as [| n']. + - destruct ls; easy. + - intros. + destruct ls; try easy. + apply IHn'. + simpl in H. + nia. +Qed. + + + +Lemma nth_switch_miss : forall {X : Type} (sn n : nat) (ls : list X) (x def : X), + n <> sn -> + nth n (switch ls x sn) def = nth n ls def. +Proof. induction sn as [| sn']. + - destruct ls. + easy. + destruct n; easy. + - intros. + destruct n. + + destruct ls; easy. + + assert (H' : n <> sn'). { nia. } + destruct ls. + easy. simpl. + apply IHsn'. + apply H'. +Qed. + + +Lemma switch_inc_helper : forall {X : Type} (n : nat) (l1 l2 : list X) (x : X), + length l1 = n -> + switch (l1 ++ l2) x n = l1 ++ switch l2 x 0. +Proof. induction n as [| n']. + - destruct l1. + reflexivity. + easy. + - intros. destruct l1. + easy. + simpl. + rewrite <- IHn'. + reflexivity. + simpl in H. + injection H. + easy. +Qed. + + +Lemma switch_inc_helper2 : forall {X : Type} (n : nat) (ls : list X) (x : X), + n < length ls -> switch ls x n = (firstn n ls) ++ switch (skipn n ls) x 0. +Proof. intros. + assert (H' : switch ls x n = switch (firstn n ls ++ skipn n ls) x n). + { rewrite (firstn_skipn n ls). reflexivity. } + rewrite H'. + rewrite switch_inc_helper. + reflexivity. + rewrite firstn_length_le. + reflexivity. + nia. +Qed. + + + +Lemma skipn_nil_length : forall {X : Type} (n : nat) (ls : list X), + skipn n ls = [] -> length ls <= n. +Proof. intros. + rewrite <- (firstn_skipn n ls). + rewrite H. + rewrite <- app_nil_end. + apply firstn_le_length. +Qed. + + +Lemma skipskip : forall {X : Type} (ls : list X) (n : nat), + skipn (S n) ls = skipn 1 (skipn n ls). +Proof. induction ls as [| h]. + - destruct n. easy. easy. + - destruct n. easy. + assert (H : skipn (S n) (h :: ls) = skipn n ls). + { reflexivity. } + rewrite H. + rewrite <- IHls. + reflexivity. +Qed. + + +Lemma switch_inc_helper3 : forall {X : Type} (n : nat) (ls : list X) (x : X), + n < length ls -> switch (skipn n ls) x 0 = [x] ++ (skipn (S n) ls). +Proof. intros. destruct (skipn n ls) as [| h] eqn:E. + - apply skipn_nil_length in E. nia. + - assert (H' : skipn (S n) ls = l). + { rewrite skipskip. + rewrite E. + reflexivity. } + rewrite H'. + reflexivity. +Qed. + + +Lemma switch_inc : forall {X : Type} (n : nat) (ls : list X) (x : X), + n < length ls -> switch ls x n = (firstn n ls) ++ [x] ++ (skipn (S n) ls). +Proof. intros. + rewrite switch_inc_helper2. + rewrite switch_inc_helper3. + reflexivity. + apply H. apply H. +Qed. + + +Lemma nth_base : forall {X : Type} (ls : list X) (x : X), + ls <> [] -> ls = (nth 0 ls x) :: (skipn 1 ls). +Proof. intros. + destruct ls. + easy. + reflexivity. +Qed. + + +Lemma nth_helper : forall {X : Type} (n : nat) (ls : list X) (x : X), + n < length ls -> skipn n ls = [nth n ls x] ++ skipn (S n) ls. +Proof. induction n as [| n']. + - destruct ls. easy. easy. + - intros. destruct ls. + assert (H' : forall (n : nat), S n < 0 -> False). { nia. } + apply H' in H. easy. + rewrite skipn_cons. + assert (H'' : nth (S n') (x0 :: ls) x = nth n' ls x). { easy. } + rewrite H''. + rewrite (IHn' ls x). + easy. + simpl in H. + assert (H''' : forall (n m : nat), S m < S n -> m < n). { nia. } + apply H''' in H. + easy. +Qed. + + + +Lemma nth_inc : forall {X : Type} (n : nat) (ls : list X) (x : X), + n < length ls -> ls = (firstn n ls) ++ [nth n ls x] ++ (skipn (S n) ls). +Proof. intros. + rewrite <- nth_helper. + rewrite (firstn_skipn n ls). + reflexivity. easy. +Qed. + + + + + + + + +Lemma length_change : forall {X : Type} (A B : list X) (x : X), + 2 ^ (length (A ++ [x] ++ B)) = (2 ^ (length A)) * (2 * (2 ^ (length B))). +Proof. intros. + do 2 (rewrite app_length). + simpl. + rewrite easy_pow. + reflexivity. +Qed. + + + + +(* a similar lemma to the one defined by Coq, but better for our purposes *) +Lemma skipn_length' : forall {X : Type} (n : nat) (ls : list X), + length (skipn (S n) ls) = length ls - n - 1. +Proof. intros. + rewrite skipn_length. + nia. +Qed. + + +Lemma firstn_subset : forall {X : Type} (n : nat) (ls : list X), + firstn n ls ⊆ ls. +Proof. induction n as [| n']. + - easy. + - intros. destruct ls. + easy. simpl. + unfold subset_gen in *. + intros. + destruct H as [H | H]. + left; easy. + right; apply IHn'; apply H. +Qed. + +Lemma skipn_subset : forall {X : Type} (n : nat) (ls : list X), + skipn n ls ⊆ ls. +Proof. induction n as [| n']. + - easy. + - intros. destruct ls. + easy. simpl. + unfold subset_gen in *. + intros. + right; apply IHn'; apply H. +Qed. + + +(********************) +(* Other misc stuff *) +(********************) + + + +Definition Phase : Matrix 2 2 := phase_shift (PI / 2). + +Definition Phase' : Matrix 2 2 := + fun x y => match x, y with + | 0, 0 => C1 + | 1, 1 => Ci + | _, _ => C0 + end. + +Definition Tgate := phase_shift (PI / 4). + + +Lemma WF_Phase : WF_Matrix Phase. Proof. show_wf. Qed. +Lemma WF_Phase' : WF_Matrix Phase'. Proof. show_wf. Qed. +Lemma WF_Tgate: WF_Matrix Tgate. Proof. show_wf. Qed. +Lemma WF_notc : WF_Matrix notc. Proof. show_wf. Qed. + +Lemma WF_ket : forall (x : nat), WF_Matrix (ket x). +Proof. intros x. unfold ket. destruct (x =? 0). show_wf. show_wf. +Qed. + +Lemma WF_bra : forall (x : nat), WF_Matrix (bra x). +Proof. intros x. unfold bra. destruct (x =? 0). show_wf. show_wf. +Qed. + + +Hint Resolve WF_Phase WF_Phase' WF_Tgate WF_notc WF_ket WF_bra : wf_db. + +(* ran into problems with hadamard. Can probably make this more general. *) +Ltac Hhelper := + unfold Mmult; + unfold Csum; + unfold I; + simpl; + C_field_simplify; + try lca; + C_field. + + +Lemma big_kron_app : forall {n m} (l1 l2 : list (Matrix n m)), + (forall i, WF_Matrix (nth i l1 (@Zero n m))) -> + (forall i, WF_Matrix (nth i l2 (@Zero n m))) -> + ⨂ (l1 ++ l2) = (⨂ l1) ⊗ (⨂ l2). +Proof. induction l1. + - intros. simpl. rewrite (kron_1_l _ _ (⨂ l2)); try easy. + apply (WF_big_kron _ _ _ (@Zero n m)); easy. + - intros. simpl. rewrite IHl1. + rewrite kron_assoc. + do 2 (rewrite <- easy_pow). + rewrite app_length. + reflexivity. + assert (H' := H 0); simpl in H'; easy. + all : try apply (WF_big_kron _ _ _ (@Zero n m)); try easy. + all : intros. + all : assert (H' := H (S i)); simpl in H'; easy. +Qed. + + + +(****************************) +(* Proving some indentities *) +(****************************) + +Lemma Y_eq_iXZ : σy = Ci .* σx × σz. Proof. lma'. Qed. +Lemma PEqP' : Phase = Phase'. +Proof. lma'. autorewrite with Cexp_db. reflexivity. +Qed. +Lemma H_eq_Hadjoint : hadamard† = hadamard. Proof. lma'. Qed. + + +Hint Rewrite Y_eq_iXZ PEqP' H_eq_Hadjoint : id_db. + +Lemma ItimesIid : I 2 × I 2 = I 2. Proof. lma'. Qed. +Lemma XtimesXid : σx × σx = I 2. Proof. lma'. Qed. +Lemma YtimesYid : σy × σy = I 2. Proof. lma'. Qed. +Lemma ZtimesZid : σz × σz = I 2. Proof. lma'. Qed. +Lemma HtimesHid : hadamard × hadamard = I 2. Proof. lma'; Hhelper. Qed. + +Hint Resolve ItimesIid XtimesXid YtimesYid ZtimesZid HtimesHid : id_db. + +Lemma ZH_eq_HX : σz × hadamard = hadamard × σx. Proof. lma'. Qed. +Lemma XH_eq_HZ : σx × hadamard = hadamard × σz. Proof. lma'. Qed. +Lemma PX_eq_YP : Phase × σx = σy × Phase. Proof. rewrite PEqP'. lma'. Qed. +Lemma PZ_eq_ZP : Phase × σz = σz × Phase. Proof. lma'. Qed. + +Lemma cnotX1 : cnot × (σx ⊗ I 2) = (σx ⊗ σx) × cnot. Proof. lma'. Qed. +Lemma cnotX2 : cnot × (I 2 ⊗ σx) = (I 2 ⊗ σx) × cnot. Proof. lma'. Qed. +Lemma cnotZ1 : cnot × (σz ⊗ I 2) = (σz ⊗ I 2) × cnot. Proof. lma'. Qed. +Lemma cnotZ2 : cnot × (I 2 ⊗ σz) = (σz ⊗ σz) × cnot. Proof. lma'. Qed. + +Hint Resolve ZH_eq_HX XH_eq_HZ PX_eq_YP PZ_eq_ZP cnotX1 cnotX2 cnotZ1 cnotZ2 : id_db. + + + + +(************************************************************************) +(* Defining a set of vectors, linear independence, other prelims etc... *) +(************************************************************************) + + +Definition orthogonal {n m} (S : Matrix n m) : Prop := + forall i j, i <> j -> inner_product (get_vec i S) (get_vec j S) = C0. + + +Definition orthonormal {n m} (S : Matrix n m) : Prop := + orthogonal S /\ (forall (i : nat), i < m -> norm (get_vec i S) = 1%R). + +(* to match WF_Unitary *) +Definition WF_Orthonormal {n m} (S : Matrix n m) : Prop := + WF_Matrix S /\ orthonormal S. + + +Lemma inner_product_is_mult : forall {n} (i j : nat) (S : Square n), + inner_product (get_vec i S) (get_vec j S) = ((S†) × S) i j. +Proof. intros. unfold inner_product, get_vec, Mmult, adjoint. + apply Csum_eq. + apply functional_extensionality; intros. simpl. + reflexivity. +Qed. + + + +Lemma inner_product_comm_conj : forall {n} (v u : Vector n), + inner_product v u = Cconj (inner_product u v). +Proof. intros. + unfold inner_product. + assert (H' : forall A : Matrix 1 1, (A 0 0) ^* = A† 0 0). + { unfold adjoint, Cconj. + easy. } + rewrite H'. + rewrite Mmult_adjoint, adjoint_involutive. + easy. +Qed. + + +(***********************************************************) +(* Defining and proving lemmas relating to the determinant *) +(***********************************************************) + + +Fixpoint parity (n : nat) : C := + match n with + | 0 => C1 + | S 0 => -C1 + | S (S n) => parity n + end. + + +Lemma parity_S : forall (n : nat), + (parity (S n) = -C1 * parity n)%C. +Proof. intros. + induction n as [| n']; try lca. + rewrite IHn'. + simpl. lca. +Qed. + + +Fixpoint Determinant (n : nat) (A : Square n) : C := + match n with + | 0 => C1 + | S 0 => A 0 0 + | S n' => (Csum (fun i => (parity i) * (A i 0) * (Determinant n' (reduce A i 0)))%C n) + end. + + +Lemma Det_simplify : forall {n} (A : Square (S (S n))), + Determinant (S (S n)) A = + (Csum (fun i => (parity i) * (A i 0) * (Determinant (S n) (reduce A i 0)))%C (S (S n))). +Proof. intros. easy. Qed. + + +Lemma Det_simplify_fun : forall {n} (A : Square (S (S (S n)))), + (fun i : nat => parity i * A i 0 * Determinant (S (S n)) (reduce A i 0))%C = + (fun i : nat => (Csum (fun j => + (parity i) * (A i 0) * (parity j) * ((reduce A i 0) j 0) * + (Determinant (S n) (reduce (reduce A i 0) j 0)))%C (S (S n))))%C. +Proof. intros. + apply functional_extensionality; intros. + rewrite Det_simplify. + rewrite Csum_mult_l. + apply Csum_eq_bounded; intros. + lca. +Qed. + + +Lemma reduce_I : forall (n : nat), reduce (I (S n)) 0 0 = I n. +Proof. intros. + apply mat_equiv_eq. + apply WF_reduce; try lia; auto with wf_db. + rewrite easy_sub. + apply WF_I. + unfold mat_equiv; intros. + unfold reduce, I. + bdestruct (i + match (x, y) with + | (0, 0) => 1%R + | (0, 1) => 2%R + | (1, 0) => 4%R + | (1, 1) => 5%R + | _ => C0 + end. + + +Lemma Det_M22 : (Determinant 2 M22) = (Copp (3%R,0%R))%C. +Proof. lca. Qed. + + +Lemma Determinant_scale : forall {n} (A : Square n) (c : C) (col : nat), + col < n -> Determinant n (col_scale A col c) = (c * Determinant n A)%C. +Proof. induction n. + + intros. easy. + + intros. simpl. + destruct n. + - simpl. unfold col_scale. + bdestruct (0 =? col); try lia; easy. + - rewrite Cmult_plus_distr_l. + apply Csum_simplify. + * rewrite Csum_mult_l. + apply Csum_eq_bounded. + intros. + destruct col. + rewrite col_scale_reduce_same; try lia. + unfold col_scale. bdestruct (0 =? 0); try lia. + lca. + rewrite col_scale_reduce_before; try lia. + rewrite easy_sub. + rewrite IHn; try lia. + unfold col_scale. + bdestruct (0 =? S col); try lia; lca. + * destruct col. + rewrite col_scale_reduce_same; try lia. + unfold col_scale. bdestruct (0 =? 0); try lia. + lca. + rewrite col_scale_reduce_before; try lia. + rewrite easy_sub. + rewrite IHn; try lia. + unfold col_scale. + bdestruct (0 =? S col); try lia; lca. +Qed. + + +(* some helper lemmas *) +Lemma Det_diff_1 : forall {n} (A : Square (S (S (S n)))), + Determinant (S (S (S n))) (col_swap A 0 1) = + Csum (fun i => (Csum (fun j => ((A i 1) * (A (skip_count i j) 0) * (parity i) * (parity j) * + Determinant (S n) (reduce (reduce A i 0) j 0))%C) + (S (S n)))) (S (S (S n))). +Proof. intros. + rewrite Det_simplify. + rewrite Det_simplify_fun. + apply Csum_eq_bounded; intros. + apply Csum_eq_bounded; intros. + replace (col_swap A 0 1 x 0) with (A x 1) by easy. + assert (H' : @reduce (S (S (S n))) (col_swap A 0 1) x 0 x0 0 = A (skip_count x x0) 0). + { unfold reduce, col_swap, skip_count. + simpl. bdestruct (x0 (Csum (fun j => ((A i 0) * (A (skip_count i j) 1) * (parity i) * (parity j) * + Determinant (S n) (reduce (reduce A i 0) j 0))%C) + (S (S n)))) (S (S (S n))). +Proof. intros. + rewrite Det_simplify. + rewrite Det_simplify_fun. + apply Csum_eq_bounded; intros. + apply Csum_eq_bounded; intros. + apply Cmult_simplify; try easy. + assert (H' : @reduce (S (S (S n))) A x 0 x0 0 = A (skip_count x x0) 1). + { unfold reduce, col_swap, skip_count. + simpl. bdestruct (x0 Determinant n (col_swap A 0 1) = (-C1 * (Determinant n A))%C. +Proof. intros. + destruct n; try lia. + destruct n; try lia. + destruct n. + - simpl. unfold col_swap, reduce. lca. + - rewrite Det_diff_1, Det_diff_2. + apply Csum_rearrange; intros. + + unfold skip_count. + bdestruct (x Determinant n (col_swap A i (S i)) = (-C1 * (Determinant n A))%C. +Proof. induction n as [| n']. + - easy. + - intros. + destruct i. + + apply Determinant_swap_01; easy. + + simpl. destruct n'; try lia. + do 2 rewrite Csum_extend_r. + rewrite Csum_mult_l. + apply Csum_eq_bounded; intros. + rewrite col_swap_reduce_before; try lia. + rewrite IHn'; try lia. + replace (col_swap A (S i) (S (S i)) x 0) with (A x 0) by easy. + lca. +Qed. + + +Lemma Determinant_swap_ik : forall {n} (k i : nat) (A : Square n), + i + (S k) < n -> Determinant n (col_swap A i (i + (S k))) = (-C1 * (Determinant n A))%C. +Proof. induction k as [| k']. + - intros. + replace (i + 1) with (S i) by lia. + rewrite Determinant_swap_adj; try lia; lca. + - intros. + rewrite (col_swap_three A i (i + (S k')) (i + (S (S k')))); try lia. + rewrite IHk'; try lia. + replace (i + (S (S k'))) with (S (i + (S k'))) by lia. + rewrite Determinant_swap_adj; try lia. + rewrite IHk'; try lia. + lca. +Qed. + +Lemma Determinant_swap : forall {n} (A : Square n) (i j : nat), + i < n -> j < n -> i <> j -> + Determinant n (col_swap A i j) = (-C1 * (Determinant n A))%C. +Proof. intros. + bdestruct (i Determinant n A = C0. +Proof. intros n A [i [H H0]]. + destruct n; try easy. + destruct n. + destruct i; try lia. + replace C0 with (@Zero 1 1 0 0) by easy. + rewrite <- H0. easy. + destruct i. + - rewrite Det_simplify. + apply Csum_0_bounded; intros. + replace (A x 0) with (@Zero (S (S n)) 1 x 0) by (rewrite <- H0; easy). + unfold Zero; lca. + - rewrite (col_swap_inv _ 0 (S i)). + rewrite Determinant_swap; try lia. + rewrite Det_simplify. + rewrite Csum_mult_l. + apply Csum_0_bounded; intros. + replace (col_swap A 0 (S i) x 0) with + (@Zero (S (S n)) 1 x 0) by (rewrite <- H0; easy). + unfold Zero; lca. +Qed. + + +Lemma col_same_Det_0 : forall {n} (A : Square n) (i j : nat), + i < n -> j < n -> i <> j -> + get_vec i A = get_vec j A -> + Determinant n A = C0. +Proof. intros. + apply eq_neg_implies_0. + rewrite <- (Determinant_swap _ i j); try easy. + rewrite (det_by_get_vec (col_swap A i j) A); try easy; intros. + prep_matrix_equality. + destruct y; try easy. + bdestruct (i0 =? i); bdestruct (i0 =? j); try lia. + - rewrite H3, <- col_swap_get_vec, H2; easy. + - rewrite H4, col_swap_diff_order, <- col_swap_get_vec, H2; easy. + - unfold col_swap, get_vec. simpl. + bdestruct (i0 =? i); bdestruct (i0 =? j); try lia; easy. +Qed. + +Lemma col_scale_same_Det_0 : forall {n} (A : Square n) (i j : nat) (c : C), + i < n -> j < n -> i <> j -> + get_vec i A = c .* (get_vec j A) -> + Determinant n A = C0. +Proof. intros. + destruct (Ceq_dec c C0). + - apply col_0_Det_0. + exists i. + split; try easy. + rewrite H2, e. + apply Mscale_0_l. + - rewrite (col_scale_inv A j c); try easy. + rewrite Determinant_scale; try easy. + assert (H3 : Determinant n (col_scale A j c) = C0). + { apply (col_same_Det_0 _ i j); try easy. + prep_matrix_equality. + unfold get_vec, col_scale. + bdestruct (y =? 0); try easy. + bdestruct (i =? j); bdestruct (j =? j); try lia. + rewrite <- get_vec_conv. + rewrite H2. + unfold scale. + rewrite get_vec_conv. + easy. } + rewrite H3. + lca. +Qed. + + +Lemma Det_col_add_comm : forall {n} (T : Matrix (S n) n) (v1 v2 : Vector (S n)), + (Determinant (S n) (col_wedge T v1 0) + Determinant (S n) (col_wedge T v2 0) = + Determinant (S n) (col_wedge T (v1 .+ v2) 0))%C. +Proof. intros. + destruct n; try easy. + do 3 rewrite Det_simplify. + rewrite <- Csum_plus. + apply Csum_eq_bounded; intros. + repeat rewrite reduce_is_redcol_redrow. + repeat rewrite col_wedge_reduce_col_same. + unfold col_wedge, Mplus. + bdestruct (0 i <> 0 -> Determinant n (col_add A 0 i c) = Determinant n A. +Proof. intros. + destruct n; try easy. + rewrite col_add_split. + assert (H' := (@Det_col_add_comm n (reduce_col A 0) (get_vec 0 A) (c .* get_vec i A))). + rewrite easy_sub in *. + rewrite <- H'. + replace (Determinant (S n) A) with (Determinant (S n) A + C0)%C by lca. + apply Csum_simplify. + assert (H1 : col_wedge (reduce_col A 0) (get_vec 0 A) 0 = A). + { prep_matrix_equality. + unfold col_wedge, reduce_col, get_vec. + destruct y; try easy; simpl. + replace (y - 0) with y by lia; easy. } + rewrite easy_sub, H1 in *; easy. + apply (col_scale_same_Det_0 _ 0 i c); try lia. + prep_matrix_equality. + unfold get_vec, col_wedge, reduce_col, scale; simpl. + bdestruct (y =? 0); bdestruct (i =? 0); try lca; try lia. + replace (S (i - 1)) with i by lia. + easy. +Qed. + + +Lemma Determinant_col_add : forall {n} (A : Square n) (i j : nat) (c : C), + i < n -> j < n -> i <> j -> Determinant n (col_add A i j c) = Determinant n A. +Proof. intros. + destruct j. + - rewrite <- col_swap_col_add_0. + rewrite Determinant_swap. + rewrite Determinant_col_add0i. + rewrite Determinant_swap. + lca. + all : easy. + - destruct i. + rewrite Determinant_col_add0i; try easy. + rewrite <- col_swap_col_add_Si. + rewrite Determinant_swap. + rewrite Determinant_col_add0i. + rewrite Determinant_swap. + lca. + all : try easy; try lia. +Qed. + + +Lemma Determinant_col_add_many_some : forall (e n col : nat) (A : Square n) (as' : Vector n), + (skip_count col e) < n -> col < n -> + (forall i : nat, (skip_count col e) < i -> as' i 0 = C0) -> as' col 0 = C0 -> + Determinant n A = Determinant n (col_add_many col as' A). +Proof. induction e as [| e]. + - intros. + rewrite (col_add_many_col_add _ (skip_count col 0)); + try lia; try easy. + rewrite Determinant_col_add; try lia. + assert (H' : (col_add_many col (make_row_zero (skip_count col 0) as') A) = A). + { prep_matrix_equality. + unfold col_add_many, make_row_zero, skip_count, gen_new_vec, scale in *. + bdestruct (y =? col); try lia; try easy. + rewrite <- Cplus_0_l. + rewrite Cplus_comm. + apply Csum_simplify; try easy. + rewrite Msum_Csum. + apply Csum_0_bounded; intros. + destruct col; simpl in *. + bdestruct (x0 =? 1); try lca. + destruct x0; try rewrite H2; try rewrite H1; try lca; try lia. + destruct x0; try lca; rewrite H1; try lca; lia. } + rewrite H'; easy. + all : apply skip_count_not_skip. + - intros. + rewrite (col_add_many_col_add _ (skip_count col (S e))); + try lia; try easy. + rewrite Determinant_col_add; try lia. + apply IHe; try lia; try easy. + assert (H' : e < S e). lia. + apply (skip_count_mono col) in H'. + lia. + intros. + unfold skip_count, make_row_zero in *. + bdestruct (e as' col 0 = C0 -> + Determinant n A = Determinant n (col_add_many col as' A). +Proof. intros. + destruct n; try lia. + destruct n. + - assert (H' : as' == Zero). + { unfold mat_equiv; intros. + destruct col; destruct i; destruct j; try lia. + easy. } + rewrite <- col_add_many_0; easy. + - rewrite (col_add_many_mat_equiv _ _ _ (make_WF as')); + try apply mat_equiv_make_WF. + apply (Determinant_col_add_many_some n); try lia; try easy. + unfold skip_count. bdestruct (n (skip_count col e) < n -> col < n -> + (forall i : nat, (skip_count col e) < i -> as' 0 i = C0) -> as' 0 col = C0 -> + Determinant n A = Determinant n (col_add_each col as' A). +Proof. induction e as [| e]. + - intros. + rewrite (col_add_each_col_add _ (skip_count col 0)); try lia. + rewrite Determinant_col_add; try lia. + assert (H' : (make_col_zero (skip_count col 0) as') = Zero). + { apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv; intros. + unfold make_col_zero, skip_count in *. + destruct i; try lia. + destruct col; simpl in *. + all : destruct j; try easy; simpl. + destruct j; try easy; simpl. + all : apply H2; lia. } + rewrite H'. + rewrite <- col_add_each_0; easy. + assert (H' := skip_count_not_skip col 0). auto. + apply skip_count_not_skip. + intros x. destruct x; try easy. + assert (H' := skip_count_not_skip col 0). auto. + apply H; lia. + - intros. + rewrite (col_add_each_col_add _ (skip_count col (S e))); try lia. + rewrite Determinant_col_add; try lia. + apply IHe; try lia; try easy; auto with wf_db. + + assert (H' : e < S e). lia. + apply (skip_count_mono col) in H'. + lia. + + intros. + unfold skip_count, make_col_zero in *. + bdestruct (e WF_Matrix as' -> as' 0 col = C0 -> + Determinant n A = Determinant n (col_add_each col as' A). +Proof. intros. + destruct n; try easy. + destruct n. + - assert (H' : as' = @Zero 1 1). + { apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv; intros. + destruct i; destruct j; destruct col; try lia. + easy. } + rewrite H'. + unfold col_add_each. + rewrite Mmult_0_r, Mplus_0_r. + easy. + - apply (Determinant_col_add_each_some n); try lia; try easy. + unfold skip_count. + bdestruct (n Determinant n A = C0 -> linearly_dependent A. +Proof. induction n as [| n']. + - intros. + unfold Determinant in H. + assert (H1 := C1_neq_C0). + easy. + - intros. + destruct (gt_dim_lindep (reduce_row A 0)) as [v [H2 [H3 H4]]]. + lia. + apply WF_reduce_row; try lia; auto. + destruct (nonzero_vec_nonzero_elem v) as [x H5]; auto. + bdestruct (x C0 /\ A k i <> C0 -> j = k). + + +Lemma good_M_I : forall (n : nat), good_M (I n). +Proof. unfold good_M, I; intros. + destruct H as [H H0]. + bdestruct (j =? i); bdestruct (j good_M (reduce A x y). +Proof. unfold good_M; intros. + destruct H0 as [H0 H1]. + unfold reduce in *. + bdestruct (j + exists (p : Polynomial (S n)), (forall c : C, Determinant (S n) (A .+ (-c .* gM)) = eval_P (S n) p c). +Proof. induction n as [| n']. + - intros. + exists [A 0 0; - gM 0 0]. + intros. + unfold eval_P; simpl. + lca. + - intros. + exists [C1]; intros. + rewrite Det_simplify. + Admitted. + + +(* + Σ^ S (S n') + (fun i : nat => + (parity i * (A .+ - c .* gM) i 0 * Determinant (S n') (reduce (A .+ - c .* gM) i 0))%C) = + eval_P (S (S n')) [C1] c *) + + + + +Lemma connect2 : forall (n : nat) (A : Square (S n)), + exists (c : C), Determinant (S n) (A .+ (-c .* I (S n))) = C0. +Proof. intros. + assert (H' : good_M (I (S n))). + apply good_M_I. + apply (connect n A) in H'. + destruct H' as [p H]. + assert (H0 : S n > 0). lia. + apply (Fundamental_Theorem_Algebra p) in H0. + destruct H0 as [c H0]. + exists c. rewrite <- H0. + easy. +Qed. + + + +Lemma exists_eigenvector : forall (n : nat) (A : Square (S n)), + WF_Matrix A -> + exists (c : C) (v : Vector (S n)), WF_Matrix v /\ v <> Zero /\ A × v = c.* v. +Proof. intros. + destruct (connect2 n A) as [c H0]. + apply Det_0_lindep in H0. + destruct H0 as [v [H1 [H2 H3]]]. + exists c, v. + split; auto. + split; auto. + rewrite Mmult_plus_distr_r, Mscale_mult_dist_l, Mmult_1_l in H3; auto. + assert (H4 : A × v .+ (-c .* v) .+ (c .* v) = (c .* v)). + { rewrite H3. lma. } + rewrite Mplus_assoc in H4. + Search (_ .* ?b .+ _ .* ?b). + rewrite <- Mscale_plus_distr_l in H4. + replace (-c + c)%C with C0 in H4 by lca. + rewrite <- H4. + lma. + auto with wf_db. +Qed. + + + +(************************************) +(* Lemmas relating to forming bases *) +(************************************) + + +Definition form_basis {n} (v : Vector n) (non_zero : nat) : Matrix n n := + fun x y => if (y =? non_zero) + then (v x 0) + else (@e_i n y x 0). + + +Lemma WF_form_basis : forall {n} (v : Vector n) (x : nat), + WF_Matrix v -> x < n -> WF_Matrix (form_basis v x). +Proof. unfold WF_Matrix, form_basis, e_i. + intros. + bdestruct (y =? x). + apply H. + destruct H1; auto; lia. + bdestruct (x0 =? y); try easy. + bdestruct (x0 get_vec x (form_basis v x) = v. +Proof. intros. + prep_matrix_equality. + unfold get_vec, form_basis. + bdestruct (y =? 0). + rewrite <- beq_nat_refl, H0; easy. + unfold WF_Matrix in H. + rewrite H; try easy. + right. + destruct y; try lia; try easy. +Qed. + + +Lemma get_ei_in_basis : forall {n} (v : Vector n) (x y : nat), + y < n -> y <> x -> get_vec y (form_basis v x) = e_i y. +Proof. intros. + prep_matrix_equality. + unfold get_vec, form_basis. + bdestruct (y0 =? 0). + bdestruct (y =? x); try easy. + rewrite H1; easy. + unfold e_i. + bdestruct (x0 =? y); bdestruct (x0 Zero -> WF_Matrix v -> v x 0 <> C0 -> x < n -> + linearly_independent (form_basis v x) /\ get_vec x (form_basis v x) = v. +Proof. intros. + destruct n; try lia. split. + - apply (lin_indep_col_add_many_conv _ _ x _ (-C1 .* (make_row_zero x v))); try easy. + unfold scale, make_row_zero. + bdestruct (x =? x); try lia; lca. + apply (lin_indep_scale_conv _ x (/ (v x 0))). + apply nonzero_div_nonzero; easy. + assert (H' : forall A : Square (S n), A = I (S n) -> linearly_independent A). + { intros. rewrite H3. + apply lin_indep_invertible; auto with wf_db. + unfold invertible. exists (I (S n)). + unfold Minv. + split; rewrite Mmult_1_l; auto with wf_db. } + apply H'. + apply mat_equiv_eq; auto with wf_db. + apply WF_col_scale. + apply WF_col_add_many; try easy. + apply WF_form_basis; easy. + unfold mat_equiv; intros. + unfold col_scale, col_add_many, make_row_zero, + form_basis, scale, gen_new_vec, get_vec. + assert (H0' : forall a b : C, a = C0 -> (b + a = b)%C). + { intros. rewrite H5. lca. } + bdestruct (j =? x); bdestruct (j =? i). + all : try rewrite Msum_Csum. + all : try unfold scale. + rewrite H5 in *. rewrite <- H6. + rewrite H0'. + unfold I. + bdestruct (x =? x); bdestruct (x v <> Zero -> + exists S : Matrix n n, WF_Matrix S /\ linearly_independent S /\ get_vec 0 S = v. +Proof. intros. + destruct n. + - exists Zero. + split. easy. + split. + unfold linearly_independent. + intros. unfold WF_Matrix in H1. + prep_matrix_equality. + apply H1; lia. + prep_matrix_equality. + unfold get_vec, Zero. + unfold WF_Matrix in H. + rewrite H; try lia. + bdestruct (y =? 0); easy. + - assert (H' := H). + apply nonzero_vec_nonzero_elem in H'; try easy. + destruct H'. + exists (col_swap (form_basis v x) x 0). + assert (H' : x < S n). + { bdestruct (x (inner_product v v = C0 <-> v = Zero). +Proof. intros. split. + - intros. + destruct (mat_equiv_dec v Zero). + apply mat_equiv_eq; try easy. + assert (H' : v <> Zero). + { unfold not; intros. + apply n0. rewrite H1. + easy. } + apply nonzero_vec_nonzero_elem in H'; try easy. + destruct H'. + unfold WF_Matrix in H. + bdestruct (x b = a). { easy. } + apply H'' in H3. + apply H' in H3. + apply Cmod_gt_0 in H1. + rewrite H3 in H1. + lra. } + rewrite H0 in H'. + simpl in H'. lra. + assert (H' : v x 0 = C0). + { apply H. left; easy. } + rewrite H' in H1; easy. + - intros. + unfold inner_product. + rewrite H0. + rewrite Mmult_0_r. + easy. +Qed. + + +Lemma norm_zero_iff_zero : forall {n} (v : Vector n), + WF_Matrix v -> (norm v = 0%R <-> v = Zero). +Proof. intros. split. + - intros. + unfold norm in H0. + apply inner_product_zero_iff_zero in H. + unfold inner_product in H. + apply sqrt_eq_0 in H0. + apply H. + apply c_proj_eq. + apply H0. + apply norm_real. + apply inner_product_ge_0. + - intros. + rewrite H0. + unfold norm. + rewrite Mmult_0_r. + simpl. apply sqrt_0. +Qed. + + + + +(*****************************************************************************************) +(* Defining and verifying the gram_schmidt algorythm and proving v can be part of an onb *) +(*****************************************************************************************) + + + +(* proj of v onto u *) +Definition proj {n} (u v : Vector n) : Vector n := + ((inner_product u v) / (inner_product u u)) .* u. + + +Definition proj_coef {n} (u v : Vector n) : C := + ((inner_product u v) / (inner_product u u)). + + +Lemma proj_inner_product : forall {n} (u v : Vector n), + (norm u) <> 0%R -> inner_product u (proj u v) = inner_product u v. +Proof. intros. + unfold proj, inner_product. + distribute_scale. + unfold scale. + unfold Cdiv. + rewrite <- Cmult_assoc. + rewrite Cinv_l. + lca. + unfold norm in H. + intro. apply H. + rewrite H0. simpl. + rewrite sqrt_0. + easy. +Qed. + + + + +Definition gram_schmidt_on_v (n m : nat) (v : Vector n) (S : Matrix n m) := + v .+ (Msum m (fun i => (-C1) .* (proj (get_vec i S) v))). + + +Definition delta_T {n m} (T : Matrix n (S m)) (i : nat) : C := + match i =? m with + | true => C1 + | _ => - (proj_coef (get_vec i T) (get_vec m T)) + end. + + +(* slightly different version thats easier to work with in general case *) +Definition gram_schmidt_on_T (n m : nat) (T : Matrix n (S m)) : Vector n := + Msum (S m) (fun i => (delta_T T) i .* (get_vec i T)). + + + +Lemma WF_gs_on_T : forall {n m} (T : Matrix n (S m)), + WF_Matrix T -> WF_Matrix (gram_schmidt_on_T n m T). +Proof. intros. + unfold gram_schmidt_on_T. + apply WF_Msum; intros. + apply WF_scale. + unfold get_vec, WF_Matrix in *; intros. + destruct H1. + - rewrite H; auto. + bdestruct (y =? 0); easy. + - bdestruct (y =? 0); try lia; try easy. +Qed. + + +Lemma gram_schmidt_compare : forall {n m} (T : Matrix n (S m)), + inner_product (get_vec m T) (get_vec m T) <> C0 -> + gram_schmidt_on_T n m T = gram_schmidt_on_v n m (get_vec m T) (reduce_col T m). +Proof. intros. + unfold gram_schmidt_on_T, gram_schmidt_on_v. + prep_matrix_equality. + unfold Mplus. + do 2 rewrite Msum_Csum. + rewrite Cplus_comm. + rewrite <- Csum_extend_r. + apply Csum_simplify. + - apply Csum_eq_bounded. + intros. + unfold delta_T. + bdestruct (x0 =? m); try lia. + unfold proj, proj_coef. + distribute_scale. + assert (H' : get_vec x0 (reduce_col T m) = get_vec x0 T). + { prep_matrix_equality; + unfold get_vec, reduce_col. + bdestruct (x0 i < m -> inner_product (get_vec i S) (gram_schmidt_on_v n m v S) = C0. +Proof. intros. + destruct H as [H H1]. + unfold orthogonal in H. + unfold inner_product in *. + unfold gram_schmidt_on_v. + rewrite Mmult_plus_distr_l. + rewrite Mmult_Msum_distr_l. + unfold Mplus. + rewrite Msum_Csum. + rewrite (Csum_unique (-C1 * ((get_vec i S) † × v) 0 0) _ m); try lca. + exists i. split; try easy. + split. + - distribute_scale. + unfold scale. + apply H1 in H0. + assert (H' : norm (get_vec i S) <> 0%R). + { rewrite H0. lra. } + apply (proj_inner_product _ v) in H'. + unfold inner_product in H'. + rewrite H'. + reflexivity. + - intros. apply H in H2. + unfold proj. + distribute_scale. + unfold scale. + rewrite H2. + lca. +Qed. + + + +Definition f_to_vec (n : nat) (f : nat -> C) : Vector n := + fun i j => if (j =? 0) && (i C), WF_Matrix (f_to_vec n f). +Proof. intros. + unfold WF_Matrix, f_to_vec. + intros x y [H | H]. + - bdestruct (y =? 0); bdestruct (x C), + Msum (S m) (fun i => f i .* get_vec i T) = T × (f_to_vec (S m) f). +Proof. intros. + prep_matrix_equality. + rewrite Msum_Csum. + unfold Mmult. + apply Csum_eq_bounded. + intros. + unfold f_to_vec, get_vec, scale. + bdestruct (x0 gram_schmidt_on_T n m T <> Zero. +Proof. intros. + unfold not, gram_schmidt_on_T; intros. + rewrite (Msum_to_Mmult T (delta_T T)) in H0. + unfold linearly_independent in H. + apply H in H0. + assert (H' : C1 <> C0). + { apply C0_fst_neq. + simpl. + apply R1_neq_R0. } + apply H'. + assert (H'' : f_to_vec (S m) (delta_T T) m 0 = C0). + { rewrite H0. easy. } + rewrite <- H''. + unfold f_to_vec, delta_T. + bdestruct (m inner_product u (normalize v) = C0. +Proof. intros. + unfold inner_product, normalize in *. + distribute_scale. + unfold scale. + rewrite H. + lca. +Qed. + + +Lemma Cconj_simplify : forall (c1 c2 : C), c1^* = c2^* -> c1 = c2. +Proof. intros. + assert (H1 : c1 ^* ^* = c2 ^* ^*). { rewrite H; easy. } + do 2 rewrite Cconj_involutive in H1. + easy. +Qed. + + + + + + +Lemma get_vec_reduce_append_miss : forall {n m} (T : Matrix n (S m)) (v : Vector n) (i : nat), + i < m -> get_vec i (col_append (reduce_col T m) v) = get_vec i T. +Proof. intros. + prep_matrix_equality. + unfold get_vec, col_append, reduce_col. + bdestruct (i =? S m - 1); bdestruct (i get_vec m (col_append (reduce_col T m) v) = v. +Proof. intros. + unfold get_vec, col_append, reduce_col. + prep_matrix_equality. + bdestruct (y =? 0). + - bdestruct (m =? S m - 1); try lia. + rewrite H0; easy. + - rewrite H; try lia; easy. +Qed. + + +Lemma get_vec_reduce_append_over : forall {n m} (T : Matrix n (S m)) (v : Vector n) (i : nat), + WF_Matrix T -> i > m -> + get_vec i (col_append (reduce_col T m) v) = Zero. +Proof. intros. + prep_matrix_equality. + unfold get_vec, col_append, reduce_col. + bdestruct (i =? S m - 1); bdestruct (i linearly_independent T -> orthonormal (reduce_col T m) -> + orthonormal (col_append (reduce_col T m) (normalize (gram_schmidt_on_T n m T))). +Proof. intros. + split. + - unfold orthogonal. + intros. + bdestruct (m C := + fun i => if (i + smash (col_append T1 (gram_schmidt_on_T n m1 (col_append T1 v))) T2 = + @col_add_many n ((S m1) + m2) m1 (f_to_vec (m1 + m2) (delta_T' T1 v m1)) + (smash (col_append T1 v) T2). +Proof. intros. + prep_matrix_equality. + unfold smash, col_append, gram_schmidt_on_T, col_add_many. + bdestruct (y (a + b = a)%C). + intros. rewrite H4. lca. + rewrite p1. + apply Csum_eq_bounded; intros. + bdestruct (x0 =? m1); bdestruct (x0 WF_Matrix T2 -> WF_Matrix v -> v <> Zero -> + linearly_independent (smash (col_append T1 v) T2) -> + linearly_independent (smash (col_append T1 + (normalize (gram_schmidt_on_T n m1 (col_append T1 v)))) T2). +Proof. intros. + rewrite smash_scale. + apply lin_indep_scale. + unfold not; intros. + assert (H4' : (norm (gram_schmidt_on_T n m1 (col_append T1 v)) * + / norm (gram_schmidt_on_T n m1 (col_append T1 v)) = + norm (gram_schmidt_on_T n m1 (col_append T1 v)) * C0)%C). + { rewrite H4; easy. } + rewrite Cmult_0_r, Cinv_r in H4'. + assert (H5 : C1 <> C0). + { apply C0_fst_neq. + simpl. + apply R1_neq_R0. } + apply H5; easy. + unfold not; intros. + assert (H5' : WF_Matrix (gram_schmidt_on_T n m1 (col_append T1 v))). + { apply WF_gs_on_T. + apply WF_col_append; easy. } + apply norm_zero_iff_zero in H5'. + apply RtoC_inj in H5. + rewrite H5 in H5'. + apply (gram_schmidt_non_zero (col_append T1 v)). + apply lin_indep_smash in H3; easy. + apply H5'; lra. + rewrite gs_on_T_cols_add; try easy. + apply lin_indep_col_add_many; try lia; try easy. + unfold f_to_vec, delta_T'. + bdestruct (m1 WF_Matrix T2 -> WF_Matrix v -> + linearly_independent (smash (col_append T1 v) T2) -> orthonormal T1 -> + exists v1, WF_Matrix v1 /\ orthonormal (col_append T1 v1) /\ + linearly_independent (smash (col_append T1 v1) T2). +Proof. intros. + exists (normalize (gram_schmidt_on_T n m1 (col_append T1 v))). + split. unfold normalize. + apply WF_scale. + apply WF_gs_on_T. + apply WF_col_append; try easy. + split. + - apply lin_indep_smash in H2. + assert (H4 := extend_onb_ind_step_part1 (col_append T1 v)). + assert (H' : reduce_col (col_append T1 v) m1 = T1). + { intros. + prep_matrix_equality. + unfold reduce_col, col_append. + bdestruct (y WF_Matrix T2 -> + linearly_independent (smash T1 T2) -> orthonormal T1 -> + exists T2' : Matrix n m2, WF_Matrix T2' /\ orthonormal (smash T1 T2'). +Proof. induction m2 as [| m2']. + - intros. + exists Zero. + split. easy. + rewrite smash_zero; try easy. + rewrite plus_0_r. + apply H2. + - intros. + rewrite (split T2) in *. + assert (H3 := (smash_assoc T1 (get_vec 0 T2) (reduce_col T2 0))). + rewrite easy_sub in *. + simpl in *. + rewrite <- H3 in H1. + rewrite <- smash_append in H1; try easy. + assert (exists v1, WF_Matrix v1 /\ orthonormal (col_append T1 v1) /\ + linearly_independent (smash (col_append T1 v1) (reduce_col T2 0))). + { apply (extend_onb_ind_step _ _ (get_vec 0 T2)); try easy. + apply WF_reduce_col. lia. + rewrite (split T2). easy. + apply WF_get_vec. + rewrite (split T2). easy. + rewrite easy_sub in *. + assert (add1 : S (m1 + S m2') = S (S m1) + m2'). { lia. } + assert (add2 : S (m1 + 1) = S (S m1)). { lia. } + rewrite add1, add2 in H1. + apply H1. } + destruct H4 as [v [H4 [H5 H6]]]. + assert (H7 : exists T2' : Matrix n m2', + WF_Matrix T2' /\ orthonormal (smash (smash T1 v) T2')). + { apply (IHm2' _ (smash T1 v) (reduce_col T2 0)). + assert (H' : Nat.add m1 (S O) = S m1). lia. + unfold Nat.add in H'. + rewrite H'. + assert (H'' := (@WF_smash n (S m1) (S O) T1 v)). + assert (H''' : Nat.add (S m1) (S O) = S (S m1)). lia. + rewrite H''' in *. + apply H''. + easy. + easy. + assert (H7 := (WF_reduce_col 0 T2)). + rewrite easy_sub in *. + apply H7. + lia. + rewrite (split T2). + easy. + assert (add1 : S (Nat.add m1 (S m2')) = S (Nat.add (Nat.add m1 (S O)) m2')). lia. + rewrite add1 in H1. + unfold Nat.add in H1. + unfold Nat.add. + rewrite <- smash_append; try easy. + rewrite easy_sub in *. + assert (add2 : Nat.add (S (S m1)) m2' = S (Nat.add (Nat.add m1 (S O)) m2')). lia. + assert (add3 : (S (S m1)) = S (Nat.add m1 (S O))). lia. + rewrite add2, add3 in H6. + unfold Nat.add in H6. + apply H6. + rewrite <- smash_append; try easy. + assert (add4 : S (S m1) = S (Nat.add m1 (S O))). lia. + rewrite add4 in H5. + unfold Nat.add in H5. + apply H5. } + destruct H7. + rewrite smash_assoc in H7. + exists (smash v x). + split. + assert (H' : S m2' = 1 + m2'). lia. rewrite H'. + apply WF_smash; try easy. + assert (add5 : Nat.add (Nat.add (S m1) (S O)) m2' = S (Nat.add m1 (S m2'))). lia. + assert (add6 : (Init.Nat.add (S O) m2') = (S m2')). lia. + rewrite add5, add6 in H7. + apply H7. + apply WF_get_vec. + rewrite (split T2). + easy. +Qed. + + +Lemma get_vec_vec : forall {n} (v : Vector n), + WF_Matrix v -> get_vec 0 v = v. +Proof. intros. + unfold get_vec. + prep_matrix_equality. + bdestruct (y =? 0). + - rewrite H0; easy. + - unfold WF_Matrix in H. + rewrite H; try easy. + right. + bdestruct (y Zero -> WF_Matrix v -> orthonormal (normalize v). +Proof. intros. + split. + unfold orthogonal, inner_product. + intros. destruct i. + + assert (H' : get_vec j (normalize v) = Zero). + { prep_matrix_equality. + unfold get_vec, normalize. + bdestruct (y =? 0); try easy. + unfold scale. rewrite H0; try lia; lca. } + rewrite H'. + rewrite Mmult_0_r; easy. + + assert (H' : get_vec (S i) (normalize v) = Zero). + { prep_matrix_equality. + unfold get_vec, normalize. + bdestruct (y =? 0); try easy. + unfold scale. rewrite H0; try lia; lca. } + rewrite H'. + rewrite zero_adjoint_eq. + rewrite Mmult_0_l; easy. + + intros. + destruct i; try lia. + rewrite get_vec_vec. + apply normalized_norm_1. + unfold not; intros; apply H. + apply norm_zero_iff_zero in H0. + apply H0; easy. + unfold normalize. + auto with wf_db. +Qed. + + +Theorem onb_out_of_v : forall {n} (v : Vector n), + WF_Matrix v -> v <> Zero -> + exists T : Square n, WF_Orthonormal T /\ get_vec 0 T = normalize v. +Proof. intros. + destruct n as [| n]. + - assert (H' : v = Zero). + prep_matrix_equality. + rewrite H; try lia; easy. + easy. + - assert (H' : WF_Matrix (normalize v)). + { unfold normalize. + auto with wf_db. } + apply lin_indep_out_of_v in H'; try easy. + destruct H' as [S0 [H1 [H2 H3]]]. + rewrite (split S0) in H2. + apply (extend_onb (S n) n 0 (get_vec 0 S0) (reduce_col S0 0)) in H2. + destruct H2 as [T [H4 H5]]. + exists (smash (get_vec 0 S0) T). split; try easy. + assert (H' : S n = 1 + n). lia. rewrite H'. + unfold WF_Orthonormal; split. + apply WF_smash; try easy. + apply WF_get_vec; easy. + easy. + apply WF_get_vec; easy. + apply (WF_reduce_col 0) in H1. + rewrite easy_sub in *; easy. + lia. + rewrite H3; apply orthonormal_normalize_v; easy. + unfold not; intros; apply H0. + prep_matrix_equality. + assert (H2 : (normalize v) x y = C0). + { rewrite H1; easy. } + unfold Zero; simpl. + unfold normalize, scale in H2. + destruct (Ceq_dec (v x y) C0); try easy. + assert (H3 : norm v <> 0%R). + { unfold not; intros. + apply norm_zero_iff_zero in H. + apply H in H3; easy. } + assert (H4 : / norm v <> C0). + { destruct (Ceq_dec (/ norm v) C0); try easy. + assert (H4' : (norm v * / norm v = norm v * C0)%C). + rewrite e; easy. + rewrite Cmult_0_r, Cinv_r in H4'. + assert (H5 : C1 <> C0). + { apply C0_fst_neq. + simpl. + apply R1_neq_R0. } + easy. + apply RtoC_neq; easy. } + apply (Cmult_neq_0 _ (v x y)) in H4; easy. +Qed. + + +(********************************************************************) +(* Defining unitary matrices and proving some basic lemmas/examples *) +(********************************************************************) + + +Lemma P_unitary : WF_Unitary Phase. Proof. apply phase_unitary. Qed. +Lemma T_unitary : WF_Unitary Tgate. +Proof. unfold WF_Unitary. + split; auto with wf_db. + lma'. unfold Mmult, adjoint, I. + simpl. + assert (H : (Cexp (PI / 4)) ^* = Cexp (- PI / 4)). + { autorewrite with Cexp_db. lca. } + assert (H1 : (- PI / 4 = - (PI / 4))%R ). { lra. } + rewrite H1 in H; rewrite H. + rewrite Cexp_mul_neg_l. lca. +Qed. + + +Lemma notc_unitary : WF_Unitary notc. +Proof. + split. + apply WF_notc. + unfold Mmult, I. + prep_matrix_equality. + do 4 (try destruct x; try destruct y; try lca). + replace ((S (S (S (S x))) (c * c ^*)%C = C1 -> WF_Unitary (c .* A). +Proof. intros. + destruct H. + split; auto with wf_db. + distribute_adjoint. + distribute_scale. + rewrite Cmult_comm. + rewrite H1, H0. + lma'. +Qed. + + +Lemma unit_big_kron : forall (n : nat) (ls : list (Square n)), + (forall a, In a ls -> WF_Unitary a) -> WF_Unitary (⨂ ls). +Proof. intros. induction ls as [| h]. + - simpl. apply id_unitary. + - simpl. + apply kron_unitary. + apply (H h). + left. easy. + apply IHls. + intros. + apply H. right. easy. +Qed. + + +Hint Resolve σx_unitary σy_unitary σz_unitary P_unitary H_unitary T_unitary : unit_db. +Hint Resolve cnot_unitary notc_unitary id_unitary Mmult_unitary kron_unitary transpose_unitary unit_scale unit_big_kron: unit_db. + + + +Lemma unit_is_orthonormal : forall {n} (U : Square n), + WF_Unitary U <-> WF_Orthonormal U. +Proof. intros n U. split. + - split; try apply H. + split. + * unfold orthogonal. intros. + rewrite inner_product_is_mult. + destruct H as [H1 H]. + rewrite H. + unfold I. bdestruct (i =? j); try lia; easy. + * intros. unfold norm. + assert (H1 : ((get_vec i U) † × get_vec i U) 0%nat 0%nat = + inner_product (get_vec i U) (get_vec i U)). + { unfold inner_product. reflexivity. } + rewrite H1. rewrite inner_product_is_mult. + destruct H. + rewrite H2. unfold I. + bdestruct (i =? i); bdestruct (i v <> Zero -> + exists S : Matrix n n, WF_Unitary S /\ get_vec 0 S = normalize v. +Proof. intros. + apply onb_out_of_v in H; try easy. + destruct H as [S [H1 H2]]. + exists S. split; try easy. + apply unit_is_orthonormal; easy. +Qed. + + +Lemma det_by_unit : forall {n} (A B X : Square n), + WF_Matrix A -> WF_Matrix B -> + WF_Unitary X -> (forall i, A × (get_vec i X) = B × (get_vec i X)) -> A = B. +Proof. intros. assert (H' : A × X = B × X). + { apply det_by_get_vec. intros. + do 2 (rewrite <- get_vec_mult). + apply H2. } + rewrite <- Mmult_1_r. + rewrite <- (Mmult_1_r _ _ A). + destruct H1. + apply Minv_flip in H3; auto with wf_db. + rewrite <- H3. + do 2 (rewrite <- Mmult_assoc). + rewrite H'. + reflexivity. + all : easy. +Qed. + + +(***********************************************************************************) +(* We now define diagonal matrices and diagonizable matrices, proving basic lemmas *) +(***********************************************************************************) + +Definition WF_Diagonal {n : nat} (A : Square n) : Prop := + WF_Matrix A /\ forall i j, i <> j -> A i j = C0. + + +Lemma diag_Zero : forall n : nat, WF_Diagonal (@Zero n n). +Proof. intros n. split; auto with wf_db. Qed. + +Lemma diag_I : forall n : nat, WF_Diagonal (I n). +Proof. + intros. + split; auto with wf_db. + intros. + unfold I. + bdestruct (i =? j); try lia; try easy. +Qed. + +Lemma diag_I1 : WF_Diagonal (I 1). Proof. apply diag_I. Qed. + +Lemma diag_scale : forall {n : nat} (r : C) (A : Square n), + WF_Diagonal A -> WF_Diagonal (r .* A). +Proof. + intros n r A [H H0]. + split; auto with wf_db. + intros. + unfold scale. + rewrite H0; try lca; easy. +Qed. + +Lemma diag_plus : forall {n} (A B : Square n), + WF_Diagonal A -> WF_Diagonal B -> WF_Diagonal (A .+ B). +Proof. + intros n A B [H H0] [H1 H2]. + split; auto with wf_db. + intros. + unfold Mplus. + rewrite H0, H2; try easy; lca. +Qed. + +Lemma diag_mult : forall {n : nat} (A B : Square n), + WF_Diagonal A -> WF_Diagonal B -> WF_Diagonal (A × B). +Proof. + intros n A B [H H0] [H1 H2]. + split; auto with wf_db. + intros. + unfold Mmult. + apply Csum_0. + intro. + bdestruct (x =? i). + + rewrite H2; try lia; lca. + + rewrite H0, Cmult_0_l. + reflexivity. auto. +Qed. + +(* short lemma to prove diag_kron *) +Lemma div_mod_eq : forall (a b m : nat), + m <> 0 -> (a / m = b / m) -> (a mod m = b mod m) -> a = b. +Proof. intros a b m H0 Hdiv Hmod. + rewrite (Nat.mod_eq a m), (Nat.mod_eq b m) in Hmod. + rewrite Hdiv in Hmod. + assert (H : m * (b / m) + (a - m * (b / m)) = m * (b / m) + (b - m * (b / m))). + { rewrite Hmod. reflexivity. } + rewrite <- (le_plus_minus (m * (b / m)) a) in H. + rewrite <- (le_plus_minus (m * (b / m)) b) in H. + apply H. + apply Nat.mul_div_le; apply H0. + rewrite <- Hdiv; apply Nat.mul_div_le; apply H0. + apply H0. apply H0. +Qed. + + +Lemma diag_kron : forall {n m : nat} (A : Square n) (B : Square m), + WF_Diagonal A -> WF_Diagonal B -> WF_Diagonal (A ⊗ B). +Proof. + intros n m A B [H H0] [H1 H2]. + destruct m. + rewrite (WF0_Zero_l 0); try easy. + auto with wf_db. + split; auto with wf_db. + unfold kron. + intros. + bdestruct (i / (S m) =? j / (S m)). + - bdestruct (i mod (S m) =? j mod (S m)). + + apply (div_mod_eq i j (S m)) in H5; try easy. + + rewrite H2; try lca; easy. + - rewrite H0; try lca; easy. +Qed. + + +Lemma diag_transpose : forall {n : nat} (A : Square n), + WF_Diagonal A -> WF_Diagonal A⊤. +Proof. intros n A [H H0]. + split; auto with wf_db. + intros. + unfold transpose. + apply H0. auto. +Qed. + +Lemma diag_adjoint : forall {n : nat} (A : Square n), + WF_Diagonal A -> WF_Diagonal A†. +Proof. intros n A [H H0]. + split; auto with wf_db. + unfold adjoint, Cconj. + intros. + rewrite H0. lca. auto. +Qed. + + +Lemma diag_kron_n : forall (n : nat) {m : nat} (A : Square m), + WF_Diagonal A -> WF_Diagonal (kron_n n A). +Proof. + intros. + induction n; simpl. + - apply diag_I. + - rewrite Nat.mul_comm. + apply (@diag_kron (m^n) m _ A). + apply IHn. apply H. +Qed. + +Lemma diag_big_kron : forall n (l : list (Square n)), + (forall A, In A l -> WF_Diagonal A) -> + WF_Diagonal (⨂ l). +Proof. + intros. + induction l. + - simpl. apply diag_I. + - simpl. apply (@diag_kron _ (n^(length l)) a (⨂ l)). + apply H. + left. easy. + apply IHl. + intros A H'. apply H. + simpl. auto. +Qed. + + +Lemma diag_Mmult_n : forall n {m} (A : Square m), + WF_Diagonal A -> WF_Diagonal (Mmult_n n A). +Proof. + intros. + induction n; simpl. + - apply diag_I. + - apply diag_mult; assumption. +Qed. + +(* defining what it means to be diagonalizable *) +Definition WF_Diagonalizable {n : nat} (A : Square n) : Prop := + WF_Matrix A /\ (exists (X X' B: Square n), + WF_Diagonal B /\ WF_Matrix X /\ WF_Matrix X' /\ X × X' = I n /\ B = X × A × X'). + +Lemma diag_imps_diagble : forall {n} (A : Square n), + WF_Diagonal A -> WF_Diagonalizable A. +Proof. intros n A [H H0]. unfold WF_Diagonalizable. + split; auto. + exists (I n), (I n), A. + split. + split; auto. + split; auto with wf_db. + split; auto with wf_db. + rewrite Mmult_1_l; auto with wf_db. + rewrite Mmult_1_l; auto with wf_db. + rewrite Mmult_1_r; auto with wf_db. +Qed. + + +Lemma diagble_Zero : forall n : nat, WF_Diagonalizable (@Zero n n). +Proof. intros. apply diag_imps_diagble. + apply diag_Zero. +Qed. + + +Lemma diagble_I : forall n : nat, WF_Diagonalizable (I n). +Proof. intros. apply diag_imps_diagble. + apply diag_I. +Qed. + +Lemma diagble_I1 : WF_Diagonal (I 1). Proof. apply diag_I. Qed. + + + +Lemma diagble_scale : forall {n : nat} (r : C) (A : Square n), + WF_Diagonalizable A -> WF_Diagonalizable (r .* A). +Proof. + intros n r A [H H0]. + split; auto with wf_db. + do 3 (destruct H0). + destruct H0 as [H1 [H2 [H3 [H4 H5]]]]. + exists x, x0, (r .* x1); split. + apply diag_scale; apply H1. + split; try easy. + split; try easy. + split. + apply H4. + rewrite Mscale_mult_dist_r; + rewrite Mscale_mult_dist_l. + rewrite H5. + reflexivity. +Qed. + + +Lemma diagble_switch : forall {n : nat} (A B X X' : Square n), + WF_Matrix A -> WF_Matrix B -> WF_Matrix X -> WF_Matrix X' -> + X × X' = I n -> B = X × A × X' -> + A = X' × B × X. +Proof. intros. + rewrite H4. + repeat rewrite <- Mmult_assoc. + apply Minv_flip in H3; auto. + rewrite H3, Mmult_1_l; auto. + rewrite Mmult_assoc. + rewrite H3, Mmult_1_r; auto. +Qed. + + +(***********************************) +(* Defining Cprod, similar to Csum *) +(***********************************) + +Fixpoint Cprod (f : nat -> C) (n : nat) : C := + match n with + | 0 => C1 + | S n' => (Cprod f n' * f n')%C + end. + + +Lemma Cprod_0_bounded : forall (f : nat -> C) (n : nat), + (exists i, i < n /\ f i = C0) -> Cprod f n = C0. +Proof. intros. + induction n as [| n']. + - destruct H; lia. + - destruct H as [i [H1 H2]]. + bdestruct (i C) (n : nat), + (forall i : nat, i < n -> f i = g i) -> Cprod f n = Cprod g n. +Proof. intros. + induction n as [| n']. + - easy. + - simpl. + rewrite IHn', H; try lia; try easy. + intros. apply H; lia. +Qed. + + + + +Lemma Cprod_extend_r : forall (f : nat -> C) (n : nat), + (Cprod f n * f n)%C = Cprod f (S n). +Proof. easy. Qed. + + +Lemma Cprod_extend_l : forall (f : nat -> C) (n : nat), + (f 0 * (Cprod (fun x => f (S x)) n))%C = Cprod f (S n). +Proof. intros. + induction n. + + simpl; lca. + + simpl. + rewrite Cmult_assoc. + rewrite IHn. + simpl. + reflexivity. +Qed. + + +Lemma Cprod_product : forall (f g h : nat -> C) (n : nat), + (forall i, i < n -> h i = (f i * g i)%C) -> ((Cprod f n) * (Cprod g n))%C = Cprod h n. +Proof. induction n. + + intros. lca. + + intros. simpl. + rewrite <- IHn, H; try lca; try lia. + intros. apply H; try lia. +Qed. + + +(************************************) +(* Defining upper triangular matrix *) +(************************************) + +Definition upper_triangular {n} (A : Square n) : Prop := + forall i j, i > j -> A i j = C0. + + + +Lemma up_tri_Zero : forall n : nat, upper_triangular (@Zero n n). +Proof. intros n. unfold upper_triangular. reflexivity. Qed. + +Lemma up_tri_I : forall n : nat, upper_triangular (I n). +Proof. + unfold upper_triangular, I; intros. + bdestruct (i =? j); try lia; easy. +Qed. + +Lemma up_tri_I1 : upper_triangular (I 1). Proof. apply up_tri_I. Qed. + +Lemma up_tri_scale : forall {n : nat} (r : C) (A : Square n), + upper_triangular A -> upper_triangular (r .* A). +Proof. + unfold upper_triangular, scale. + intros. + rewrite H; try lca; easy. +Qed. + +Lemma up_tri_plus : forall {n} (A B : Square n), + upper_triangular A -> upper_triangular B -> upper_triangular (A .+ B). +Proof. + unfold upper_triangular, Mplus. + intros n A B H H0 i j H1. + rewrite H, H0; try lca; easy. +Qed. + + +Lemma up_tri_mult : forall {n : nat} (A B : Square n), + upper_triangular A -> upper_triangular B -> upper_triangular (A × B). +Proof. + unfold upper_triangular, Mmult. + intros n A B H H0 i j D. + apply Csum_0. + intros x. + bdestruct (x upper_triangular (reduce A 0 0). +Proof. + unfold upper_triangular, reduce. + intros. + bdestruct (i + Determinant n A = Cprod (fun i => A i i) n. +Proof. induction n as [| n']. + - easy. + - intros. simpl. + destruct n' as [| n'']. + + lca. + + assert (H' : (Cprod (fun i : nat => A i i) (S n'') * A (S n'') (S n'') = + A 0 0 * Cprod (fun i : nat => (reduce A 0 0) i i) (S n''))%C). + { rewrite <- Cprod_extend_l. + rewrite <- Cprod_extend_r. + rewrite <- Cmult_assoc; easy. } + rewrite H'. + rewrite <- Csum_extend_l. + rewrite <- Cplus_0_r. + rewrite <- Cplus_assoc. + apply Csum_simplify. + simpl parity. + rewrite IHn'; try lca. + apply up_tri_reduce_0; easy. + unfold upper_triangular in H. + rewrite H; try lia. + rewrite <- Cplus_0_r. + apply Csum_simplify; try lca. + apply Csum_0_bounded. + intros. + rewrite H; try lia; lca. +Qed. + + + +Lemma det_multiplicative_up_tri : forall {n} (A B : Square n), + upper_triangular A -> upper_triangular B -> + (Determinant n A * Determinant n B)%C = Determinant n (A × B). +Proof. intros. + rewrite det_up_tri_diags; try easy. + rewrite det_up_tri_diags; try easy. + rewrite det_up_tri_diags; try apply up_tri_mult; try easy. + apply Cprod_product. + intros. unfold Mmult. + apply Csum_unique. + exists i. + split. easy. split. easy. + intros. + bdestruct (i Eigenpair (I n) (v, C1). +Proof. intros n v H. unfold Eigenpair. + simpl. rewrite Mmult_1_l. lma. + easy. +Qed. + + +Lemma diags_have_basis_eigens : forall (n : nat) (U : Square n) (i : nat), + (i < n) -> WF_Diagonal U -> Eigenpair U (e_i i, U i i). +Proof. unfold WF_Diagonal, Eigenpair, e_i. intros. + unfold Mmult, scale. + prep_matrix_equality. + eapply Csum_unique. exists i. + destruct H0 as [H0 H1]. + split. apply H. + split. + - simpl. bdestruct (x =? i). + * rewrite H2. bdestruct (i =? i); easy. + * rewrite H1. lca. lia. + - intros. simpl. bdestruct (x' =? i); try lia; lca. +Qed. + + +Lemma eigen_scale : forall {n} (A : Square n) (v : Vector n) (c1 c2 : C), + Eigenpair A (v, c1) -> Eigenpair (c2 .* A) (v, Cmult c1 c2). +Proof. intros. + unfold Eigenpair in *; simpl in *. + rewrite Mscale_mult_dist_l. + rewrite H. + rewrite Mscale_assoc. + rewrite Cmult_comm. + reflexivity. +Qed. + + +Lemma eigen_scale_div : forall {n} (A : Square n) (v : Vector n) (c1 c2 : C), + c2 <> C0 -> Eigenpair (c2 .* A) (v, Cmult c2 c1) -> Eigenpair A (v, c1). +Proof. intros. + unfold Eigenpair in *; simpl in *. + rewrite <- Mscale_assoc in H0. + rewrite Mscale_mult_dist_l in H0. + apply Mscale_div in H0; + assumption. +Qed. + + + +Lemma eig_unit_invertible : forall {n} (v : Vector n) (c : C) (X X' B : Square n), + WF_Matrix v -> WF_Matrix X -> WF_Matrix X' -> X' × X = I n -> + Eigenpair B (X × v, c) -> Eigenpair (X' × B × X) (v, c). +Proof. intros. + unfold Eigenpair in *; simpl in *. + do 2 (rewrite Mmult_assoc). + rewrite H3. + distribute_scale. + rewrite <- Mmult_assoc. + rewrite H2. + rewrite Mmult_1_l; easy. +Qed. + + + +Lemma eig_unit_conv : forall {n} (v : Vector n) (c : C) (U B : Square n), + WF_Matrix v -> WF_Unitary U -> + Eigenpair B (U × v, c) -> Eigenpair (U† × B × U) (v, c). +Proof. intros. + destruct H0 as [H0 H2]. + unfold Eigenpair in *; simpl in *. + do 2 (rewrite Mmult_assoc). + rewrite H1. + rewrite Mscale_mult_dist_r. + rewrite <- Mmult_assoc. + rewrite H2. + rewrite Mmult_1_l; easy. +Qed. + + + + +Lemma eig_unit_norm1 : forall {n} (U : Square n) (c : C), + WF_Unitary U -> (exists v, WF_Matrix v /\ v <> Zero /\ Eigenpair U (v, c)) -> (c * c^* = C1)%C. +Proof. intros. destruct H0 as [v [H0 [H1 H2]]]. + unfold Eigenpair in H2; simpl in H2. + assert (H3 : (U × v)† = (c .* v)†). rewrite H2; easy. + rewrite Mmult_adjoint, Mscale_adj in H3. + assert (H4 : ((v) † × (U) †) × (U × v) = (c ^* .* (v) †) × (c .* v)). + { rewrite H2, H3; easy. } + rewrite Mmult_assoc in H4. + rewrite <- (Mmult_assoc _ U v) in H4. + destruct H as [H5 H]. + rewrite H in H4. + rewrite Mmult_1_l in H4; auto. + rewrite Mscale_mult_dist_r in H4. + rewrite Mscale_mult_dist_l in H4. + rewrite Mscale_assoc in H4. + assert (H' : ((v) † × v) 0 0 = (c * c ^* .* ((v) † × v)) 0 0). + rewrite <- H4; easy. + assert (H'' : ((v) † × v) 0 0 = inner_product v v). easy. + unfold scale in H'. + rewrite H'' in H'. + apply (Cmult_simplify (inner_product v v) (c * c ^* * inner_product v v) + (/ (inner_product v v)) (/ (inner_product v v))) in H'; try easy. + rewrite <- Cmult_assoc in H'. + rewrite Cinv_r in H'. + rewrite H'; lca. + unfold not; intros; apply H1. + apply inner_product_zero_iff_zero in H0. + apply H0; easy. +Qed. + + +Lemma unit_has_eigen : forall {n} (A : Square (S n)), + WF_Unitary A -> + exists (c : C) (v : Vector (S n)), Eigenpair A (v, c) /\ v <> Zero /\ WF_Matrix v. +Proof. intros n A [Hwf Hu]. + apply exists_eigenvector in Hwf. + destruct Hwf as [c [v [H [H0 H1]]]]. + exists c. exists v. + split. unfold Eigenpair. + simpl; easy. + auto. +Qed. + +Lemma unitary_reduction_step1 : forall {n} (A : Square (S n)), + WF_Unitary A -> + exists X, WF_Unitary X /\ + (exists c : C, get_vec 0 (X†×A×X) = c .* e_i 0). +Proof. intros n A [Hwf Hu]. + apply exists_eigenvector in Hwf. + destruct Hwf as [c [v [H [H0 H1]]]]. + assert (H' := H0). + apply onb_out_of_v in H0; auto. + destruct H0 as [T [H2 H3]]. + exists T. split. + apply unit_is_orthonormal; easy. + exists c. + rewrite matrix_by_basis; try lia. + do 2 rewrite Mmult_assoc. + rewrite <- matrix_by_basis, H3; try lia. + unfold normalize. + rewrite Mscale_mult_dist_r. + rewrite H1. + distribute_scale. + assert (H'' : forall p1 p2 : C, p1 = p2 -> fst p1 = fst p2). + intros. rewrite H0; easy. + assert (H4 : v = (norm v) .* normalize v). + { unfold normalize; distribute_scale. + rewrite Cinv_r; try lma. + apply norm_zero_iff_zero in H. + unfold not; intros. + apply H'. + apply H. + unfold RtoC in H0. + apply H'' in H0. + simpl in H0. + easy. } + rewrite H4, <- H3. + apply unit_is_orthonormal in H2. + destruct H2 as [Hwf HTu]. + rewrite matrix_by_basis; try lia. + distribute_scale. + rewrite <- Mmult_assoc, HTu. + rewrite <- matrix_by_basis, H3, <- H4; try lia. + rewrite Cmult_comm, Cmult_assoc, Cinv_r, Mmult_1_l; auto with wf_db. + lma. unfold not;intros. + apply H'. + apply norm_zero_iff_zero in H. + unfold RtoC in H0. + apply H'' in H0; simpl in H0. + apply H; easy. +Qed. + + +(* this proof is horribly long and I feel like theres probably a better way to show this *) +(* TODO : make this better *) +Lemma unitary_reduction_step2 : forall {n} (A : Square (S n)), + WF_Unitary A -> + (exists c : C, get_vec 0 A = c .* e_i 0) -> + (forall (i j : nat), (i = 0 \/ j = 0) /\ i <> j -> A i j = C0). +Proof. intros n A H [c H0] i j H1. + assert (Hc : A 0 0 = c). + { replace (A 0 0) with ((get_vec 0 A) 0 0) by easy. + rewrite H0; lca. } + assert (H2 : (c * c^*)%C = C1). + { apply (eig_unit_norm1 A); try easy. + exists (e_i 0). + split. + apply WF_e_i. + split. unfold not; intros. + apply C1_neq_C0. + replace C1 with (@e_i (S n) 0 0 0) by easy. + rewrite H2; easy. + unfold Eigenpair; simpl. + rewrite <- matrix_by_basis; try easy; lia. } + destruct H1 as [[H1 | H1] H3]. + - apply transpose_unitary in H. + apply unit_is_orthonormal in H. + destruct H as [Hwf [Ho Hn]]. + assert (H4 : norm (get_vec 0 A†) = 1%R). + { apply Hn; lia. } + unfold norm in H4. + apply sqrt_1_unique in H4. + replace 1%R with (fst C1) in H4 by easy. + apply (c_proj_eq (((get_vec 0 A†) † × get_vec 0 A†) 0 0) C1) in H4. + unfold Mmult in H4. + rewrite <- Csum_extend_l in H4. + assert (H' : ((get_vec 0 (A) †) † 0 0 * get_vec 0 (A) † 0 0)%C = C1). + { unfold get_vec, adjoint. + simpl. rewrite Hc. + rewrite Cconj_involutive; easy. } + rewrite H' in H4. + assert (H'' : forall c : C, (C1 + c = C1 -> -C1 + (C1 + c) = -C1 + C1)%C). + { intros. rewrite H; easy. } + apply H'' in H4. + rewrite Cplus_assoc in H4. + replace (-C1 + C1)%C with C0 in H4 by lca. + rewrite Cplus_0_l in H4. + rewrite H1 in *. + destruct j; try lia. + assert (H5 := Csum_squeeze (fun x : nat => ((get_vec 0 (A) †) † 0 (S x) * + get_vec 0 (A) † (S x) 0)%C) n). + assert (H5' : forall x : nat, + x < n -> + fst ((fun x0 : nat => ((get_vec 0 (A) †) † 0 (S x0) * get_vec 0 (A) † (S x0) 0)%C) x) = + fst C0). + { apply H5. intros. + unfold adjoint, get_vec, Copp. + simpl. + rewrite Ropp_involutive. + unfold Rminus. + replace (- (snd (A 0%nat (S x)) * - snd (A 0%nat (S x))))%R with + ((snd (A 0%nat (S x)))^2)%R by lra. + replace (fst (A 0%nat (S x)) * fst (A 0%nat (S x)))%R with + ((fst (A 0%nat (S x)))^2)%R by lra. + apply Rplus_le_le_0_compat. + all : try apply pow2_ge_0. + rewrite H4; easy. } + simpl in H5'. + assert (H6 := (H5' j)). + bdestruct (j + (forall (i j : nat), (i = 0 \/ j = 0) /\ i <> j -> A i j = C0) -> + exists (A' : Square n), WF_Unitary A' /\ pad A' (A 0 0) = A. +Proof. intros n A [Hwf Hu]. + exists (reduce A 0 0). + assert (H' : WF_Matrix (reduce A 0 0)). + { apply WF_reduce; try lia; easy. } + split. split. + rewrite easy_sub in *. + apply H'. + apply mat_equiv_eq; auto with wf_db. + apply WF_mult; try apply WF_adjoint. + all : rewrite easy_sub in *; try easy. + unfold mat_equiv; intros. + assert (H2 : ((A) † × A) (S i) (S j) = (I n) i j). + { rewrite Hu. + unfold I. + bdestruct_all; try easy. } + rewrite <- H2. + unfold Mmult. + rewrite <- Csum_extend_l. + rewrite H, Cmult_0_r, Cplus_0_l. + apply Csum_eq_bounded; intros. + unfold adjoint. + unfold reduce. + apply Cmult_simplify. + all : simpl; try easy. + lia. + unfold pad, reduce, col_wedge, row_wedge, scale, e_i. + prep_matrix_equality. + simpl. + bdestruct_all; simpl. + rewrite H1, H2; lca. + 3 : { destruct x; destruct y; try lia. + do 2 rewrite easy_sub; easy. } + 4 : { destruct x; destruct y; try lia. + do 2 rewrite easy_sub; easy. } + all : try rewrite (H x y); try lca; try lia. +Qed. + + +Lemma diagble_pad : forall {n} (A : Square n) (c : C), + WF_Diagonalizable A -> WF_Diagonalizable (pad A c). +Proof. intros n A c [H [X [X' [B [[Hwf Hd] [H1 [H2 [H3 H4]]]]]]]]. + split. apply WF_pad; auto. + exists (pad X C1), (pad X' C1), (pad B c). + split. split; try (apply WF_pad; auto). + - intros. + destruct i; destruct j; try lia; + unfold pad, col_wedge, row_wedge, scale, e_i; + bdestruct_all; try easy; try lca. + do 2 rewrite easy_sub. + apply Hd; lia. + apply Hd; lia. + - split; try (apply WF_pad; auto). + split; try (apply WF_pad; auto). + split. + rewrite <- pad_mult, H3, Cmult_1_r, pad_I. + easy. + do 2 rewrite <- pad_mult. + rewrite <- H4, Cmult_1_r, Cmult_1_l. + easy. +Qed. + + +(* Now, we build up the main important theorem *) +Theorem unit_implies_diagble : forall {n} (A : Square n), + WF_Unitary A -> WF_Diagonalizable A. +Proof. induction n as [| n']. + - intros A [H H0]. + apply WF0_Zero_l in H. + rewrite H. + apply diagble_Zero. + - intros A H. + assert (H0 := H). + apply unitary_reduction_step1 in H. + destruct H as [X [H1 [c H2]]]. + assert (H3 : WF_Unitary ((X) † × A × X)). + { do 2 try apply Mmult_unitary. + apply transpose_unitary. + all : easy. } + assert (H4 : (forall (i j : nat), (i = 0 \/ j = 0) /\ i <> j -> ((X) † × A × X) i j = C0)). + { apply unitary_reduction_step2; try easy. + exists c. easy. } + apply unitary_reduction_step3 in H3; try easy. + destruct H3 as [A' [H5 H6]]. + assert (H7 : WF_Diagonalizable ((X) † × A × X)). + apply IHn' in H5. + { rewrite <- H6. + apply diagble_pad. + easy. } + destruct H7 as [Hwf Hd]. + split. + destruct H0; easy. + destruct Hd as [X0 [X0' [B [H7 [H8 [H9 [H10 H11]]]]]]]. + exists (X0 × (X) †). + exists (X × X0'). + exists B. + destruct H1 as [H1wf H1u]. + split; try easy. + split; auto with wf_db. + split; auto with wf_db. + rewrite Mmult_assoc. + rewrite <- (Mmult_assoc X †). + rewrite H1u. + rewrite Mmult_1_l; try easy. + split; try easy. + rewrite H11. + repeat rewrite Mmult_assoc. + easy. +Qed. + + +(************************************************************************************) +(* Showing that certain types of matrices are equal when their eigenpairs are equal *) +(************************************************************************************) + + +Definition eq_eigs {n : nat} (U1 U2 : Square n) : Prop := + forall p, WF_Matrix (fst p) -> (Eigenpair U1 p -> Eigenpair U2 p). + + +Lemma eq_eigs_implies_eq_diag : forall {n} (D1 D2 : Square n), + WF_Diagonal D1 -> WF_Diagonal D2 -> eq_eigs D1 D2 -> D1 = D2. +Proof. intros n D1 D2 [H1wf H1d] [H2wf H2d] H. + assert (H2 : forall x, x < n -> D1 x x = D2 x x). + { intros. + assert (H1 := H0). + apply (diags_have_basis_eigens n D1 x) in H1. + apply H in H1. + unfold Eigenpair in H1; simpl in H1. + assert (H' : (D1 x x .* @e_i n x) x 0 = D1 x x). + { unfold scale, e_i. + bdestruct_all; lca. } + rewrite <- H', <- H1. + unfold Mmult. + apply (Csum_unique (D2 x x)). + exists x. split; try easy. + split. unfold e_i. + bdestruct_all; lca. + intros. + unfold e_i; bdestruct_all; lca. + simpl. auto with wf_db. + split; auto. } + apply mat_equiv_eq; auto. + unfold mat_equiv; intros. + bdestruct (i =? j). + - rewrite H3, H2; try lia; easy. + - rewrite H1d, H2d; try lia; easy. +Qed. + + +Lemma diagble_eigenpairs_transfer : forall {n} (A B X X' : Square n), + WF_Matrix A -> WF_Diagonal B -> WF_Matrix X -> WF_Matrix X' -> + A = X' × B × X -> X × X' = I n -> + (forall x, x < n -> Eigenpair A (X' × (e_i x), B x x)). +Proof. intros. + destruct H0 as [Hwf Hu]. + unfold Eigenpair; simpl. + rewrite <- Mmult_assoc. + rewrite H3. + do 2 rewrite Mmult_assoc. + rewrite <- (Mmult_assoc X), H4, Mmult_1_l; auto with wf_db. + assert (H' := (diags_have_basis_eigens n B)). + apply H' in H5. + unfold Eigenpair in H5; simpl in H5. + rewrite Mmult_assoc, H5. + distribute_scale; easy. + split; auto. +Qed. + +Lemma eq_eigs_implies_eq_diagble : forall {n} (D1 D2 : Square n), + WF_Diagonalizable D1 -> WF_Diagonalizable D2 -> eq_eigs D1 D2 -> D1 = D2. +Proof. intros n D1 D2 [H1wf H1d] [H2wf H2d] H. + destruct H1d as [X1 [X1' [B1 [[Hb1wf Hb1u] [H12 [H13 [H14 H15]]]]]]]. + destruct H2d as [X2 [X2' [B2 [[Hb2wf Hb2u] [H22 [H23 [H24 H25]]]]]]]. + apply diagble_switch in H15; apply diagble_switch in H25; auto. + assert (H0 : D1 × X1' = X1' × B1). + { rewrite H15. + repeat rewrite Mmult_assoc. + rewrite H14, Mmult_1_r; auto. } + assert (H1 : D2 × X2' = X2' × B2). + { rewrite H25. + repeat rewrite Mmult_assoc. + rewrite H24, Mmult_1_r; auto. } + assert (H2 : forall i, i < n -> Eigenpair D1 (X1' × (e_i i), B1 i i)). + { apply (diagble_eigenpairs_transfer D1 B1 X1 X1'); auto. + split; auto. } + assert (H3 : forall i, i < n -> Eigenpair D2 (X1' × (e_i i), B1 i i)). + { intros. apply H. simpl. + auto with wf_db. apply H2; easy. } + assert (H4 : forall i, i < n -> Eigenpair (X1 × D1 × X1') (e_i i, B1 i i)). + { intros. apply eig_unit_invertible; auto with wf_db. } + assert (H5 : forall i, i < n -> Eigenpair (X1 × D2 × X1') (e_i i, B1 i i)). + { intros. apply eig_unit_invertible; auto with wf_db. } + assert (H6 : forall i, i < n -> (X1 × D1 × X1' × e_i i = X1 × D2 × X1' × e_i i)). + { intros. + unfold Eigenpair in *; simpl in *. + rewrite H4, H5; easy. } + assert (H7 : X1 × D1 × X1' = X1 × D2 × X1'). + { apply det_by_get_vec. + intros. + bdestruct (i = n -> WF_Matrix A -> + get_vec i A = @Zero n 1). + { intros. + unfold get_vec. + prep_matrix_equality. + bdestruct_all; try easy. + rewrite H9; try lia; easy. } + rewrite H'; auto with wf_db. + rewrite H'; auto with wf_db. } + assert (H8 : X1' × (X1 × D1 × X1') × X1= X1' × (X1 × D2 × X1') × X1). + { rewrite H7; easy. } + repeat rewrite Mmult_assoc in H8. + apply Minv_flip in H14; auto. + rewrite H14 in H8. + do 2 rewrite Mmult_1_r in H8; auto. + do 2 rewrite <- Mmult_assoc in H8. + rewrite H14 in H8. + do 2 rewrite Mmult_1_l in H8; auto. +Qed. + + + +Lemma eq_eigs_implies_eq_unit : forall {n} (U1 U2 : Square n), + WF_Unitary U1 -> WF_Unitary U2 -> eq_eigs U1 U2 -> U1 = U2. +Proof. intros. + apply unit_implies_diagble in H. + apply unit_implies_diagble in H0. + apply eq_eigs_implies_eq_diagble; auto. +Qed. + + +Theorem eigs_eq_gate : forall {n} (U1 U2 : Square n), + WF_Unitary U1 -> WF_Unitary U2 -> (U1 = U2 <-> eq_eigs U1 U2). +Proof. intros. split. + - intros H'; rewrite H'; easy. + - apply eq_eigs_implies_eq_unit. + apply H. apply H0. +Qed. + + + +Local Close Scope nat_scope. + +(*******************************) +(* Some actual examples/lemmas *) +(*******************************) + + + +Definition qubitP : Vector 2 := / (√ 2) .* (∣0⟩ .+ ∣1⟩). +Definition qubitM : Vector 2 := / (√ 2) .* (∣0⟩ .+ ((-1) .* ∣1⟩)). +Definition EPRpair : Vector 4 := / (√ 2) .* (∣0,0⟩ .+ ∣1,1⟩). + +Lemma EPRpair_creation : cnot × (hadamard ⊗ I 2) × ∣0,0⟩ = EPRpair. +Proof. unfold EPRpair. lma'. +Qed. + + +Notation "∣+⟩" := qubitP. +Notation "∣-⟩" := qubitM. +Notation "∣Φ+⟩" := EPRpair. + +Lemma WF_qubitP : WF_Matrix ∣+⟩. Proof. show_wf. Qed. +Lemma WF_qubitM : WF_Matrix ∣-⟩. Proof. show_wf. Qed. +Lemma WF_EPRpair : WF_Matrix ∣Φ+⟩. Proof. unfold EPRpair. auto with wf_db. Qed. + +Hint Resolve WF_qubitP WF_qubitM WF_EPRpair : wf_db. + +Lemma EigenXp : Eigenpair σx (∣+⟩, C1). +Proof. unfold Eigenpair. lma'. +Qed. + +Lemma EigenXm : Eigenpair σx (∣-⟩, -C1). +Proof. unfold Eigenpair. lma'. +Qed. + +Lemma EigenZ0 : Eigenpair σz (∣0⟩, C1). +Proof. unfold Eigenpair. lma'. +Qed. + +Lemma EigenZ1 : Eigenpair σz (∣1⟩, -C1). +Proof. unfold Eigenpair. lma'. +Qed. + +Lemma EigenXXB : Eigenpair (σx ⊗ σx) (∣Φ+⟩, C1). +Proof. unfold Eigenpair. lma'. +Qed. + + +Hint Resolve EigenXp EigenXm EigenZ0 EigenZ1 EigenXXB all_v_eigen_I : eig_db. + diff --git a/Heisenberg.v b/Heisenberg.v new file mode 100644 index 0000000..37726d4 --- /dev/null +++ b/Heisenberg.v @@ -0,0 +1,2582 @@ +Require Import Psatz. +Require Import String. +Require Import Program. +Require Import List. + + +Require Export Complex. +Require Export Matrix. +Require Export Quantum. +Require Export Eigenvectors. + + + +(* Some helpers *) + + +(* this is trivial but helps shorten proofs and Ltacs *) +Lemma kill_true : forall P : Prop, + P /\ True <-> P. +Proof. split. intros [H _]. easy. + intros. split. easy. easy. +Qed. + +Lemma in_simplify : forall {X} (x x1 : X), + In x1 [x] -> x1 = x. +Proof. intros. simpl in H. + destruct H. easy. easy. +Qed. + + + + +(**************************************) +(* defining Heisenberg representation *) +(**************************************) + + +Declare Scope heisenberg_scope. +Delimit Scope heisenberg_scope with H. +Open Scope heisenberg_scope. + + + +Notation vecType n := (list (Square n)). + + +Definition singVecType {n : nat} (v : Vector n) (U : Square n) : Prop := + WF_Matrix v /\ exists λ, Eigenpair U (v, λ). + + +Definition vecHasType {n : nat} (v : Vector n) (ts: vecType n) : Prop := + forall (A : Square n), In A ts -> singVecType v A. + +(* an alternate definition which helps with singleton tactics later *) +Fixpoint vecHasType' {n : nat} (v : Vector n) (ts: vecType n) : Prop := + match ts with + | [] => True + | (t :: ts') => (singVecType v t) /\ vecHasType' v ts' + end. + +Lemma vecHasType_is_vecHasType' : forall (n : nat) (v : Vector n) (A : vecType n), + vecHasType v A <-> vecHasType' v A. +Proof. intros n v A. split. + - induction A as [| h]. + * easy. + * intros H. + simpl. split. + + unfold vecHasType in H. + apply H. + simpl; left; reflexivity. + + apply IHA. + unfold vecHasType in H. + unfold vecHasType; intros. + apply H; simpl; right; apply H0. + - induction A as [| h]. + * easy. + * intros [H1 H2]. + unfold vecHasType; intros. + apply IHA in H2. + unfold vecHasType in H2. + destruct H as [H3 | H4]. + rewrite <- H3; apply H1. + apply H2; apply H4. +Qed. + + +Notation "v :' T" := (vecHasType v T) (at level 61) : heisenberg_scope. + + +Notation "A ∩ B" := (A ++ B) (at level 60, no associativity) : heisenberg_scope. + + + +(*****************************) +(* Basic vectType operations *) +(*****************************) + + +(* Singleton says if a vectType is able to be multiplied, scaled, or kronned *) +Definition Singleton {n : nat} (A : vecType n) := + match A with + | [a] => True + | _ => False + end. + + +(* helper lemma to immediatly turn singleton vecType into [a] form *) +Lemma singleton_simplify : forall {n} (A : vecType n), + Singleton A -> exists (a : Square n), A = [a]. +Proof. intros; destruct A. + easy. + destruct A. + exists m. + reflexivity. + easy. +Qed. + + + +(* multiplies every combination of lists A and B *) +Fixpoint mul {n : nat} (A B : vecType n) := + match A with + | [] => [] + | (a :: as') => List.map (fun b => a × b) B ++ mul as' B + end. + + + +Definition scale {n : nat} (c : C) (A : vecType n) := + List.map (fun a => c .* a) A. + + +Definition i {n : nat} (A : vecType n) := + scale Ci A. + +Definition neg {n : nat} (A : vecType n) := + scale (-1) A. + +(* tensor similar to mul *) +Fixpoint tensor {n m : nat} (A : vecType n) (B : vecType m) : vecType (n * m) := + match A with + | [] => [] + | (a :: as') => List.map (fun b => a ⊗ b) B ++ tensor as' B + end. + + +Fixpoint big_tensor {n} (As : list (vecType n)) : + vecType (n^(length As)) := + match As with + | [] => [I 1] + | A :: As' => tensor A (big_tensor As') + end. + + +Fixpoint tensor_n n {m} (A : vecType m) := + match n with + | 0 => [I 1] + | S n' => tensor (tensor_n n' A) A + end. + + + +Notation "- T" := (neg T) : heisenberg_scope. +Infix "*'" := mul (at level 40, left associativity) : heisenberg_scope. +Infix "⊗'" := tensor (at level 51, right associativity) : heisenberg_scope. +Infix "·" := scale (at level 45, left associativity) : heisenberg_scope. +Notation "n ⨂' A" := (tensor_n n A) (at level 30, no associativity) : heisenberg_scope. +Notation "⨂' A" := (big_tensor A) (at level 60): heisenberg_scope. + +(*****************************************************) +(* helper lemmas to extract from mult, tensor, scale *) +(*****************************************************) + + +Lemma in_mult : forall {n} (p : Square n) (A B : vecType n), + In p (A *' B) -> exists a b, In a A /\ In b B /\ p = a × b. +Proof. intros. induction A as [| h]. + - simpl in H. easy. + - simpl in H. + apply in_app_or in H; destruct H as [H | H]. + * apply in_map_iff in H. destruct H. + exists h, x. split. + simpl. left. easy. destruct H as [H H']. + split. apply H'. rewrite H; reflexivity. + * apply IHA in H. do 2 (destruct H). + exists x, x0. + destruct H as [H1 H2]. + split. simpl. right; apply H1. + apply H2. +Qed. + + +Lemma in_tensor : forall {n m} (p : Square (n*m)) (A : vecType n) (B : vecType m), + In p (A ⊗' B) -> exists a b, In a A /\ In b B /\ p = a ⊗ b. +Proof. intros. induction A as [| h]. + - simpl in H. easy. + - simpl in H. + apply in_app_or in H; destruct H as [H | H]. + * apply in_map_iff in H. destruct H. + exists h, x. split. + simpl. left. easy. destruct H as [H H']. + split. apply H'. rewrite H; reflexivity. + * apply IHA in H. do 2 (destruct H). + exists x, x0. + destruct H as [H1 H2]. + split. simpl. right; apply H1. + apply H2. +Qed. + + +Lemma in_scale : forall {n} (p : Square n) (c : C) (A : vecType n), + In p (c · A) -> exists a, In a A /\ p = c .* a. +Proof. intros. induction A as [| h]. + - simpl in H. easy. + - simpl in H. + destruct H as [H | H]. + * exists h. split. + left. easy. + rewrite H. reflexivity. + * apply IHA in H. do 2 (destruct H). + exists x. split. + right. apply H. + apply H0. +Qed. + + +Lemma in_scale_rev : forall {n} (p : Square n) (c : C) (A : vecType n), + In p A -> In (c .* p) (c · A). +Proof. intros. induction A as [| h]. + - simpl in H. easy. + - simpl in H. + destruct H as [H0 | H0]. + * left. rewrite H0. reflexivity. + * right. apply IHA. apply H0. +Qed. + +(******************) +(* Singleton laws *) +(******************) + +Definition X' : vecType 2 := [σx]. +Definition Z' : vecType 2 := [σz]. +Definition I' : vecType 2 := [I 2]. + +Definition I_n (n : nat) : vecType n := [I n]. + + +Lemma SI : Singleton I'. Proof. easy. Qed. +Lemma SX : Singleton X'. Proof. easy. Qed. +Lemma SZ : Singleton Z'. Proof. easy. Qed. +Lemma SI_n : forall (n : nat), Singleton (I_n n). Proof. easy. Qed. + +Lemma S_neg : forall (n : nat) (A : vecType n), Singleton A -> Singleton (neg A). +Proof. intros n A H. + apply singleton_simplify in H. + destruct H; rewrite H. + easy. +Qed. + +Lemma S_i : forall (n : nat) (A : vecType n), Singleton A -> Singleton (i A). +Proof. intros n A H. + apply singleton_simplify in H. + destruct H; rewrite H. + easy. +Qed. + +Lemma S_mul : forall (n : nat) (A B : vecType n), + Singleton A -> Singleton B -> Singleton (A *' B). +Proof. intros n A B HA HB. + apply singleton_simplify in HA; + apply singleton_simplify in HB; + destruct HA; destruct HB; rewrite H, H0. + easy. +Qed. + +Lemma S_tensor : forall (n m : nat) (A : vecType n) (B : vecType m), + Singleton A -> Singleton B -> Singleton (A ⊗' B). +Proof. intros n m A B HA HB. + apply singleton_simplify in HA; + apply singleton_simplify in HB; + destruct HA; destruct HB; rewrite H, H0. + easy. +Qed. + + +Lemma tensor_nil_r : forall (n m : nat) (A : vecType n), @tensor n m A [] = []. +Proof. induction A as [| h]. + - easy. + - simpl. apply IHA. +Qed. + + +Lemma S_tensor_conv : forall (n m : nat) (A : vecType n) (B : vecType m), + Singleton (A ⊗' B) -> Singleton A /\ Singleton B. +Proof. intros n m A B H. + destruct A. easy. + destruct B. rewrite tensor_nil_r in H. easy. + destruct A. destruct B. + easy. easy. destruct B. + easy. easy. +Qed. + +Lemma S_big_tensor : forall (n : nat) (As : list (vecType n)), + (forall a, In a As -> Singleton a) -> Singleton (⨂' As). +Proof. intros. induction As as [| h]. + - easy. + - simpl. apply S_tensor. + apply H; left; easy. + apply IHAs. + intros. + apply H; right; apply H0. +Qed. + +Lemma S_big_tensor_conv : forall (n : nat) (As : list (vecType n)) (a : vecType n), + Singleton (⨂' As) -> In a As -> Singleton a. +Proof. intros. induction As as [| h]. + - easy. + - destruct H0 as [Hh | Ha]. + + simpl in H. + apply S_tensor_conv in H. + rewrite <- Hh; easy. + + apply IHAs. + simpl in H. + apply S_tensor_conv in H. + easy. + apply Ha. +Qed. + + +Lemma S_tensor_subset : forall (n : nat) (As Bs : list (vecType n)), + Singleton (⨂' As) -> Bs ⊆ As -> Singleton (⨂' Bs). +Proof. intros. + unfold subset_gen in H0. + apply S_big_tensor. + intros. + apply H0 in H1. + apply (S_big_tensor_conv n As a) in H. + apply H. + apply H1. +Qed. + + +Hint Resolve SI SX SZ SI_n S_neg S_i S_mul S_tensor : sing_db. + +Notation Y' := (i (X' *' Z')). + +Lemma SY : Singleton Y'. +Proof. auto with sing_db. Qed. + +(****************) +(* Unitary laws *) +(****************) + + +Definition uni_vecType {n : nat} (vt : vecType n) : Prop := + forall A, In A vt -> WF_Unitary A. + + +Lemma uni_vecType_cons : forall {n : nat} (a : Square n) (A : vecType n), + uni_vecType (a :: A) -> WF_Unitary a /\ uni_vecType A. +Proof. intros. + split. + - apply H. + left; easy. + - unfold uni_vecType in *. + intros. + apply H. + right; easy. +Qed. + +Lemma univ_I : uni_vecType I'. +Proof. unfold uni_vecType. intros. + apply in_simplify in H; rewrite H. + auto with unit_db. +Qed. + +Lemma univ_X : uni_vecType X'. +Proof. unfold uni_vecType. intros. + apply in_simplify in H; rewrite H. + auto with unit_db. +Qed. + + +Lemma univ_Z : uni_vecType Z'. +Proof. unfold uni_vecType. intros. + apply in_simplify in H; rewrite H. + apply σz_unitary. +Qed. + +Lemma univ_I_n : forall (n : nat), uni_vecType (I_n n). +Proof. unfold uni_vecType. intros. + apply in_simplify in H; rewrite H. + auto with unit_db. +Qed. + +Lemma univ_neg : forall (n : nat) (A : vecType n), uni_vecType A -> uni_vecType (neg A). +Proof. unfold uni_vecType in *. + intros n A H a H1. unfold neg in H1. + apply in_scale in H1. destruct H1 as [x [H1 H2]]. + apply H in H1. + destruct H1 as [H1 H3]. + rewrite H2. split; auto with wf_db. + rewrite Mscale_adj. + distribute_scale. rewrite H3. + lma. +Qed. + +Lemma univ_i : forall (n : nat) (A : vecType n), uni_vecType A -> uni_vecType (i A). +Proof. unfold uni_vecType in *. + intros n A H a H1. unfold neg in H1. + apply in_scale in H1. destruct H1 as [x [H1 H2]]. + apply H in H1. + destruct H1 as [H1 H3]. + rewrite H2. split; auto with wf_db. + rewrite Mscale_adj. + distribute_scale. rewrite H3. + lma. +Qed. + + +Lemma univ_mul : forall (n : nat) (A B : vecType n), + uni_vecType A -> uni_vecType B -> uni_vecType (A *' B). +Proof. unfold uni_vecType in *. + intros n A B HA HB ab Hab. + apply in_mult in Hab. + destruct Hab as [a [b [Ha [Hb Hab]]]]. + rewrite Hab. + auto with unit_db. +Qed. + + +Lemma univ_tensor : forall (n m : nat) (A : vecType n) (B : vecType m), + uni_vecType A -> uni_vecType B -> uni_vecType (A ⊗' B). +Proof. unfold uni_vecType in *. + intros n m A B HA HB ab Hab. + apply in_tensor in Hab. + destruct Hab as [a [b [Ha [Hb Hab]]]]. + rewrite Hab. + auto with unit_db. +Qed. + +Local Open Scope nat_scope. + + +(* alternate version that is sometimes necessary *) +Lemma univ_tensor' : forall (n m o : nat) (A : vecType n) (B : vecType m), + n * m = o -> uni_vecType A -> uni_vecType B -> @uni_vecType o (A ⊗' B). +Proof. unfold uni_vecType in *. + intros n m o A B H HA HB ab Hab. + rewrite <- H. + apply in_tensor in Hab. + destruct Hab as [a [b [Ha [Hb Hab]]]]. + rewrite Hab. + auto with unit_db. +Qed. + +Lemma univ_tensor_list : forall (n : nat) (A : list (vecType n)), + (forall a, In a A -> uni_vecType a) -> uni_vecType (⨂' A). +Proof. intros. + induction A as [| h]. + - simpl. + replace [I 1] with (I_n 1) by auto. + apply univ_I_n. + - simpl. + apply univ_tensor. + apply (H h); left; auto. + apply IHA; intros. + apply H; right; auto. +Qed. + +Hint Resolve univ_I univ_X univ_Z univ_I_n univ_neg univ_i univ_mul univ_tensor : univ_db. + + +Lemma univ_Y : uni_vecType Y'. +Proof. auto with univ_db. Qed. + + +Local Close Scope nat_scope. + +(***********************) +(* Multiplication laws *) +(***********************) + +(* some helper lemmas *) +Lemma cons_conc : forall (X : Type) (x : X) (ls : list X), + x :: ls = [x] ++ ls. +Proof. reflexivity. Qed. + +Lemma mul_sing : forall (n : nat) (a b : Square n), + [a] *' [b] = [a × b]. +Proof. reflexivity. +Qed. + +Lemma mul_nil_l : forall (n : nat) (A : vecType n), [] *' A = []. +Proof. simpl. reflexivity. +Qed. + +Lemma mul_nil_r : forall (n : nat) (A : vecType n), A *' [] = []. +Proof. intros n A. induction A as [| a]. + - simpl. reflexivity. + - simpl. apply IHA. +Qed. + +Lemma cons_into_mul_l : forall (n : nat) (a : Square n) (A B : vecType n), + (a :: A) *' B = ([a] *' B) ++ (A *' B). +Proof. intros n a A B. simpl. + rewrite <- app_nil_end. + reflexivity. +Qed. + +Lemma concat_into_mul_l : forall (n : nat) (A B C : vecType n), + (A ++ B) *' C = (A *' C) ++ (B *' C). +Proof. intros n A B C. induction A as [| a]. + - simpl. reflexivity. + - rewrite cons_into_mul_l. + rewrite cons_conc. rewrite app_ass. + rewrite <- cons_conc. + rewrite cons_into_mul_l. + rewrite IHA. rewrite app_ass. + reflexivity. +Qed. + + +Lemma sing_concat_into_mul_r : forall (n : nat) (a : Square n) (B C : vecType n), + [a] *' (B ++ C) = ([a] *' B) ++ ([a] *' C). +Proof. intros n a B C. simpl. + do 3 (rewrite <- app_nil_end). + rewrite map_app. + reflexivity. +Qed. + + +Lemma sing_mul_assoc : forall (n : nat) (a b : Square n) (C : vecType n), + [a] *' [b] *' C = [a] *' ([b] *' C). +Proof. intros n a b C. induction C as [| c]. + - simpl. reflexivity. + - rewrite (cons_conc _ c C). + rewrite (sing_concat_into_mul_r n b [c] C). + do 2 (rewrite mul_sing). + rewrite (sing_concat_into_mul_r n _ [c] C). + rewrite (sing_concat_into_mul_r n a _ _). + rewrite <- IHC. + do 3 (rewrite mul_sing). + rewrite Mmult_assoc. + reflexivity. +Qed. + +Lemma sing_mul_assoc2 : forall (n : nat) (a : Square n) (B C : vecType n), + [a] *' B *' C = [a] *' (B *' C). +Proof. intros n a B C. induction B as [| b]. + - simpl. reflexivity. + - rewrite (cons_conc _ b B). + rewrite sing_concat_into_mul_r. + do 2 (rewrite concat_into_mul_l). + rewrite sing_concat_into_mul_r. + rewrite sing_mul_assoc. + rewrite IHB. + reflexivity. +Qed. + + +Theorem mul_assoc : forall (n : nat) (A B C : vecType n), A *' (B *' C) = A *' B *' C. +Proof. intros n A B C. induction A as [| a]. + - simpl. reflexivity. + - rewrite cons_conc. + do 3 (rewrite concat_into_mul_l). + rewrite IHA. + rewrite sing_mul_assoc2. + reflexivity. +Qed. + +Lemma mul_I_l : forall (A : vecType 2), uni_vecType A -> I' *' A = A. +Proof. intros A H. unfold I'. induction A as [| a]. + - reflexivity. + - rewrite (cons_conc _ a A). + rewrite sing_concat_into_mul_r. + apply uni_vecType_cons in H. + destruct H as [[H _] H0]. + rewrite IHA; try easy. + simpl. + rewrite Mmult_1_l; easy. +Qed. + +Lemma mul_I_r : forall (A : vecType 2), uni_vecType A -> A *' I' = A. +Proof. intros A H. unfold I'. induction A as [| a]. + - reflexivity. + - rewrite cons_into_mul_l. + apply uni_vecType_cons in H. + destruct H as [[H _] H0]. + rewrite IHA; try easy. + simpl. + rewrite Mmult_1_r; try easy. +Qed. + +Lemma Xsqr : X' *' X' = I'. +Proof. simpl. unfold I. rewrite XtimesXid. reflexivity. +Qed. + +Lemma Zsqr : Z' *' Z' = I'. +Proof. simpl. unfold I. rewrite ZtimesZid. reflexivity. +Qed. + +Lemma ZmulX : Z' *' X' = - (X' *' Z'). +Proof. simpl. assert (H : σz × σx = -1 .* (σx × σz)). + { lma'. } rewrite H. reflexivity. +Qed. + + +Lemma scale_1_l : forall (n : nat) (A : vecType n), 1 · A = A. +Proof. intros n A. induction A as [|a]. + - reflexivity. + - simpl. rewrite IHA. + rewrite Mscale_1_l. + reflexivity. +Qed. + +Lemma scale_assoc : forall (n : nat) (a b : C) (A : vecType n), + a · (b · A) = (a * b) · A. +Proof. intros n a b A. induction A as [| h]. + - reflexivity. + - simpl. rewrite IHA. + rewrite Mscale_assoc. + reflexivity. +Qed. + + +Lemma neg_inv : forall (n : nat) (A : vecType n), - - A = A. +Proof. intros n A. unfold neg. + rewrite scale_assoc. + assert (H: -1 * -1 = 1). { lca. } + rewrite H. rewrite scale_1_l. + reflexivity. +Qed. + +Lemma concat_into_scale : forall (n : nat) (c : C) (A B : vecType n), + c · (A ++ B) = (c · A) ++ (c · B). +Proof. intros n c A B. + unfold scale. + rewrite map_app. + reflexivity. +Qed. + +Lemma scale_sing : forall (n : nat) (c : C) (a : Square n), + c · [a] = [c .* a]. +Proof. reflexivity. +Qed. + +Lemma sing_scale_dist_l : forall (n : nat) (c : C) (a : Square n) (B : vecType n), + (c · [a]) *' B = c · ([a] *' B). +Proof. intros n c a B. induction B as [|b]. + - reflexivity. + - rewrite (cons_conc _ b B). + rewrite sing_concat_into_mul_r. + rewrite concat_into_scale. + rewrite scale_sing. + rewrite sing_concat_into_mul_r. + rewrite <- IHB. rewrite scale_sing. + do 2 (rewrite mul_sing). + rewrite scale_sing. + rewrite Mscale_mult_dist_l. + reflexivity. +Qed. + + +Lemma scale_dist_l : forall (n : nat) (c : C) (A B : vecType n), (c · A) *' B = c · (A *' B). +Proof. intros n c A B. induction A as [|a]. + - reflexivity. + - rewrite cons_into_mul_l. rewrite cons_conc. + do 2 (rewrite concat_into_scale). + rewrite concat_into_mul_l. + rewrite IHA. rewrite sing_scale_dist_l. + reflexivity. +Qed. + + +(* note that this is slightly different than what we would expect. *) +(* scaling is on right, but singleton is still left list *) +Lemma sing_scale_dist_r : forall (n : nat) (c : C) (a : Square n) (B : vecType n), + [a] *' (c · B) = c · ([a] *' B). +Proof. intros n c a B. induction B as [| b]. + - reflexivity. + - rewrite (cons_conc _ b B). + rewrite sing_concat_into_mul_r. + do 2 (rewrite concat_into_scale). + rewrite sing_concat_into_mul_r. + rewrite IHB. + rewrite scale_sing. + do 2 (rewrite mul_sing). + rewrite scale_sing. + rewrite Mscale_mult_dist_r. + reflexivity. +Qed. + +Lemma scale_dist_r : forall (n : nat) (c : C) (A B : vecType n), A *' (c · B) = c · (A *' B). +Proof. intros n c A B. induction A as [|a]. + - reflexivity. + - rewrite cons_into_mul_l. + rewrite (cons_into_mul_l n a A B). + rewrite concat_into_scale. + rewrite IHA. + rewrite sing_scale_dist_r. + reflexivity. +Qed. + + +Lemma neg_dist_l : forall (n : nat) (A B : vecType n), -A *' B = - (A *' B). +Proof. intros n A B. + unfold neg. + rewrite scale_dist_l. reflexivity. +Qed. + +Lemma neg_dist_r : forall (n : nat) (A B : vecType n), A *' -B = - (A *' B). +Proof. intros n A B. + unfold neg. + rewrite scale_dist_r. reflexivity. +Qed. + +Lemma i_sqr : forall (n : nat) (A : vecType n), i (i A) = -A. +Proof. intros n A. unfold neg. unfold i. + rewrite scale_assoc. + assert (H: Ci * Ci = -1). { lca. } + rewrite H. + reflexivity. +Qed. + + +Lemma i_dist_l : forall (n : nat) (A B : vecType n), i A *' B = i (A *' B). +Proof. intros n A B. + unfold i. + rewrite scale_dist_l. reflexivity. +Qed. + +Lemma i_dist_r : forall (n : nat) (A B : vecType n), A *' i B = i (A *' B). +Proof. intros n A B. + unfold i. + rewrite scale_dist_r. reflexivity. +Qed. + +Lemma i_neg_comm : forall (n : nat) (A : vecType n), i (-A) = -i A. +Proof. intros n A. unfold neg; unfold i. + do 2 (rewrite scale_assoc). + assert (H: Ci * -1 = -1 * Ci). + { lca. } rewrite H. reflexivity. +Qed. + +Hint Rewrite mul_sing mul_nil_r mul_I_l mul_I_r Xsqr Zsqr ZmulX neg_inv scale_dist_l scale_dist_r neg_dist_l neg_dist_r i_sqr i_dist_l i_dist_r i_neg_comm : mul_db. + + + + + +(***************) +(* Tensor Laws *) +(***************) + + +Lemma tensor_1_l : forall (n : nat) (A : vecType n), + uni_vecType A -> [I 1] ⊗' A = A. +Proof. intros. induction A as [| h]. + - easy. + - simpl in *. + apply uni_vecType_cons in H. + destruct H as [[H _] H0]. + rewrite kron_1_l; try easy. + rewrite IHA; try easy. +Qed. + + +Lemma big_tensor_1_l : forall (n m : nat) (A : vecType n), + uni_vecType A -> (@big_tensor m []) ⊗' A = A. +Proof. intros. + assert (H' : forall m, (@big_tensor m []) = [I 1]). + { easy. } + rewrite H'. + apply tensor_1_l. + easy. +Qed. + + +(* basically, we need the same helper lemmas for tensoring *) +(* should all WF conditions, but I will assume all gates are well formed *) +Lemma tensor_sing : forall (m n : nat) (a : Square n) (b : Square m), + [a] ⊗' [b] = [a ⊗ b]. +Proof. reflexivity. +Qed. + + +Lemma cons_into_tensor_l : forall (m n : nat) (a : Square n) (A : vecType n) (B : vecType m), + (a :: A) ⊗' B = ([a] ⊗' B) ++ (A ⊗' B). +Proof. intros m n a A B. simpl. + rewrite <- app_nil_end. + reflexivity. +Qed. + +Lemma concat_into_tensor_l : forall (m n : nat) (A B : vecType n) (C : vecType m), + (A ++ B) ⊗' C = (A ⊗' C) ++ (B ⊗' C). +Proof. intros m n A B C. induction A as [| a]. + - simpl. reflexivity. + - rewrite cons_into_tensor_l. + rewrite cons_conc. rewrite app_ass. + rewrite <- cons_conc. + rewrite cons_into_tensor_l. + rewrite IHA. rewrite app_ass. + reflexivity. +Qed. + + +Lemma sing_concat_into_tensor_r : forall (m n : nat) (a : Square m) (B C : vecType n), + [a] ⊗' (B ++ C) = ([a] ⊗' B) ++ ([a] ⊗' C). +Proof. intros m n a B C. simpl. + do 3 (rewrite <- app_nil_end). + rewrite map_app. + reflexivity. +Qed. + + +Lemma sing_tensor_assoc : forall (m n o : nat) (a : Square m) (b : Square n) (C : vecType o), + WF_Matrix a -> WF_Matrix b -> uni_vecType C -> + ([a] ⊗' [b]) ⊗' C = [a] ⊗' ([b] ⊗' C). +Proof. intros m n o a b C H H0 H1. induction C as [| c]. + - simpl. reflexivity. + - rewrite (cons_conc _ c C). + apply uni_vecType_cons in H1. + destruct H1 as [H1 H2]. + rewrite (sing_concat_into_tensor_r n o b [c] C). + do 2 (rewrite tensor_sing). + rewrite (sing_concat_into_tensor_r _ o _ [c] C). + rewrite (sing_concat_into_tensor_r _ _ a _ _). + rewrite <- IHC; auto. + do 3 (rewrite tensor_sing). + rewrite kron_assoc; auto. + destruct H1; auto. +Qed. + + +Lemma sing_tensor_assoc2 : forall (m n o: nat) (a : Square m) (B : vecType n) (C : vecType o), + WF_Matrix a -> uni_vecType B -> uni_vecType C -> + ([a] ⊗' B) ⊗' C = [a] ⊗' (B ⊗' C). +Proof. intros m n o a B C H H0 H1. induction B as [| b]. + - simpl. reflexivity. + - rewrite (cons_conc _ b B). + apply uni_vecType_cons in H0. + destruct H0 as [[H0 _] H2]. + rewrite sing_concat_into_tensor_r. + do 2 (rewrite concat_into_tensor_l). + rewrite sing_concat_into_tensor_r. + rewrite sing_tensor_assoc; auto. + rewrite IHB; auto. +Qed. + + +Theorem tensor_assoc : forall (m n o: nat) (A : vecType m) (B : vecType n) (C : vecType o), + uni_vecType A -> uni_vecType B -> uni_vecType C -> + A ⊗' (B ⊗' C) = (A ⊗' B) ⊗' C. +Proof. intros m n o A B C H H0 H1. induction A as [| a]. + - simpl. reflexivity. + - rewrite cons_conc. + apply uni_vecType_cons in H. + destruct H as [[H _] H2]. + do 3 (rewrite concat_into_tensor_l); auto. + rewrite IHA; auto. + rewrite sing_tensor_assoc2; auto. +Qed. + + + +Lemma sing_scale_tensor_dist_l : forall (n m : nat) (c : C) (a : Square n) (B : vecType m), + (c · [a]) ⊗' B = c · ([a] ⊗' B). +Proof. intros n m c a B. induction B as [|b]. + - reflexivity. + - rewrite (cons_conc _ b B). + rewrite sing_concat_into_tensor_r. + rewrite concat_into_scale. + rewrite scale_sing. + rewrite sing_concat_into_tensor_r. + rewrite <- IHB. rewrite scale_sing. + do 2 (rewrite tensor_sing). + rewrite scale_sing. + rewrite Mscale_kron_dist_l. + reflexivity. +Qed. + + +Lemma scale_tensor_dist_l : forall (n m : nat) (c : C) (A : vecType n) (B : vecType m), + (c · A) ⊗' B = c · (A ⊗' B). +Proof. intros n m c A B. induction A as [|a]. + - reflexivity. + - rewrite cons_into_tensor_l. rewrite cons_conc. + do 2 (rewrite concat_into_scale). + rewrite concat_into_tensor_l. + rewrite IHA. rewrite sing_scale_tensor_dist_l. + reflexivity. +Qed. + + +(* note that this is slightly different than what we would expect. *) +(* scaling is on right, but singleton is still left list *) +Lemma sing_scale_tensor_dist_r : forall (m n : nat) (c : C) (a : Square n) (B : vecType m), + [a] ⊗' (c · B) = c · ([a] ⊗' B). +Proof. intros m n c a B. induction B as [| b]. + - reflexivity. + - rewrite (cons_conc _ b B). + rewrite sing_concat_into_tensor_r. + do 2 (rewrite concat_into_scale). + rewrite sing_concat_into_tensor_r. + rewrite IHB. + rewrite scale_sing. + do 2 (rewrite tensor_sing). + rewrite scale_sing. + rewrite Mscale_kron_dist_r. + reflexivity. +Qed. + +Lemma scale_tensor_dist_r : forall (m n : nat) (c : C) (A : vecType n) (B : vecType m), + A ⊗' (c · B) = c · (A ⊗' B). +Proof. intros m n c A B. induction A as [|a]. + - reflexivity. + - rewrite cons_into_tensor_l. + rewrite (cons_into_tensor_l m n a A B). + rewrite concat_into_scale. + rewrite IHA. + rewrite sing_scale_tensor_dist_r. + reflexivity. +Qed. + + + +Lemma neg_tensor_dist_l : forall (m n : nat) (A : vecType n) (B : vecType m), + -A ⊗' B = - (A ⊗' B). +Proof. intros m n A B. unfold neg. + rewrite scale_tensor_dist_l. + reflexivity. +Qed. + +Lemma neg_tensor_dist_r : forall (m n : nat) (A : vecType n) (B : vecType m), + A ⊗' -B = - (A ⊗' B). +Proof. intros m n A B. unfold neg. + rewrite scale_tensor_dist_r. + reflexivity. +Qed. + +Lemma i_tensor_dist_l : forall (m n : nat) (A : vecType n) (B : vecType m), + i A ⊗' B = i (A ⊗' B). +Proof. intros m n A B. unfold i. + rewrite scale_tensor_dist_l. + reflexivity. +Qed. + +Lemma i_tensor_dist_r : forall (m n : nat) (A : vecType n) (B : vecType m), + A ⊗' i B = i (A ⊗' B). +Proof. intros m n A B. unfold i. + rewrite scale_tensor_dist_r. + reflexivity. +Qed. + + +Hint Rewrite concat_into_tensor_l scale_tensor_dist_r scale_tensor_dist_l neg_tensor_dist_l neg_tensor_dist_r i_tensor_dist_l i_tensor_dist_r : tensor_db. + + +(********************************) +(* Multiplication & Tensor Laws *) +(********************************) + +Lemma mul_tensor_dist_sing : forall (m n : nat) + (a : Square m) (b : Square n) (c : Square m) (D : vecType n), + ([a] ⊗' [b]) *' ([c] ⊗' D) = ([a] *' [c]) ⊗' ([b] *' D). +Proof. intros m n a b c D. induction D as [| d]. + - reflexivity. + - rewrite (cons_conc _ d D). + rewrite sing_concat_into_tensor_r, sing_concat_into_mul_r. + rewrite mul_sing, tensor_sing. + rewrite sing_concat_into_tensor_r. + rewrite sing_concat_into_mul_r. + rewrite <- mul_sing. rewrite <- tensor_sing. + assert (H: ([a] ⊗' [b]) *' ([c] ⊗' [d]) = [a] *' [c] ⊗' [b] *' [d]). + { simpl. rewrite kron_mixed_product. reflexivity. } + rewrite H, IHD. + reflexivity. +Qed. + + +Lemma mul_tensor_dist_sing2 : forall (m n : nat) + (a : Square m) (B : vecType n) (c : Square m) (D : vecType n), + ([a] ⊗' B) *' ([c] ⊗' D) = ([a] *' [c]) ⊗' (B *' D). +Proof. intros m n a B c D. induction B as [| b]. + - reflexivity. + - rewrite (cons_conc _ b B). + rewrite sing_concat_into_tensor_r. + rewrite concat_into_mul_l. + rewrite concat_into_mul_l. + rewrite mul_sing. + rewrite sing_concat_into_tensor_r. + rewrite <- mul_sing. + rewrite IHB, mul_tensor_dist_sing. + reflexivity. +Qed. + + + +Lemma mul_tensor_dist : forall (m n : nat) + (A : vecType m) (B : vecType n) (C : vecType m) (D : vecType n), + Singleton A -> + Singleton C -> + (A ⊗' B) *' (C ⊗' D) = (A *' C) ⊗' (B *' D). +Proof. intros m n A B C D H1 H2. + apply singleton_simplify in H1; destruct H1; + apply singleton_simplify in H2; destruct H2. + rewrite H, H0. + rewrite mul_tensor_dist_sing2. + reflexivity. +Qed. + + +Lemma decompose_tensor : forall (A B : vecType 2), + Singleton A -> uni_vecType A -> + Singleton B -> uni_vecType B -> + A ⊗' B = (A ⊗' I') *' (I' ⊗' B). +Proof. + intros. + rewrite mul_tensor_dist; auto with sing_db. + rewrite mul_I_l, mul_I_r. + all : easy. +Qed. + +Lemma decompose_tensor_mult_l : forall (A B : vecType 2), + Singleton A -> + Singleton B -> + (A *' B) ⊗' I' = (A ⊗' I') *' (B ⊗' I'). +Proof. + intros. + rewrite mul_tensor_dist; auto with sing_db. + rewrite mul_I_l. + easy. + auto with univ_db. +Qed. + +Lemma decompose_tensor_mult_r : forall (A B : vecType 2), + I' ⊗' (A *' B) = (I' ⊗' A) *' (I' ⊗' B). +Proof. + intros. + rewrite mul_tensor_dist; auto with sing_db. + rewrite mul_I_l. + easy. + auto with univ_db. +Qed. + +(*********************) +(* Intersection Laws *) +(*********************) + + +Lemma has_type_subset : forall (n : nat) (v : Vector n) (t1s t2s : vecType n), + (t1s ⊆ t2s) -> v :' t2s -> v :' t1s. +Proof. intros n v t1s t2s. + unfold subset_gen; unfold vecHasType. + intros H H0 A H1. + apply H0; apply H; apply H1. +Qed. + +(* +(* converges of previous statement. Impossible to prove as long as list is multiset *) +Axiom has_type_subset_conv : forall {n} (t1s t2s : vecType n), + (forall (v : Vector n), v :' t2s -> v :' t1s) -> t1s ⊆ t2s. +*) + +Definition eq_vecType {n} (T1 T2 : vecType n) := + (forall v, WF_Matrix v -> (v :' T1 <-> v :' T2)). + + +Infix "≡" := eq_vecType (at level 70, no associativity) : heisenberg_scope. + +(* will now show this is an equivalence relation *) +Lemma eq_vecType_refl : forall {n} (A : vecType n), A ≡ A. +Proof. intros n A. + unfold eq_vecType. easy. +Qed. + +Lemma eq_vecType_sym : forall {n} (A B : vecType n), A ≡ B -> B ≡ A. +Proof. intros n A B H. + unfold eq_vecType in *; intros v. + split. + all : apply H; easy. +Qed. + +Lemma eq_vecType_trans : forall {n} (A B C : vecType n), + A ≡ B -> B ≡ C -> A ≡ C. +Proof. + intros n A B C HAB HBC. + unfold eq_vecType in *. + split. + - intros. apply HBC; auto; apply HAB; auto; apply H. + - intros. apply HAB; auto; apply HBC; auto; apply H. +Qed. + + +Add Parametric Relation n : (vecType n) (@eq_vecType n) + reflexivity proved by eq_vecType_refl + symmetry proved by eq_vecType_sym + transitivity proved by eq_vecType_trans + as eq_vecType_rel. + + + +(* converse of this is true as well since matrices are unitary? *) +(* probably hard to prove on coq *) +Lemma eq_types_same_type : forall (n : nat) (T1 T2 : vecType n), + (T1 ⊆ T2 /\ T2 ⊆ T1) -> T1 ≡ T2. +Proof. intros n T1 T2 [S12 S21]. + unfold eq_vecType. + intros v; split. + - apply has_type_subset. apply S21. + - apply has_type_subset. apply S12. +Qed. + + + + +Lemma cap_idem : forall (n : nat) (A : vecType n), A ∩ A ≡ A. +Proof. intros n A. + apply eq_types_same_type. + split. + - auto with sub_db. + - auto with sub_db. +Qed. + +Lemma cap_comm : forall (n : nat) (A B : vecType n), A ∩ B ≡ B ∩ A. +Proof. intros n A B. + apply eq_types_same_type. + split. + - auto with sub_db. + - auto with sub_db. +Qed. + +Lemma cap_assoc_eq : forall (n : nat) (A B C : vecType n), A ∩ (B ∩ C) = (A ∩ B) ∩ C. +Proof. intros n A B C. rewrite app_ass. reflexivity. +Qed. + + + +Lemma cap_I_l : forall {n} (A : vecType n), + (I_n n) ∩ A ≡ A. +Proof. intros n A. + unfold eq_vecType. + intros v; split. + - apply has_type_subset. + auto with sub_db. + - intros H0. + unfold vecHasType; intros A0. + simpl. + intros [H1 | H1']. + + rewrite <- H1. + unfold singVecType in *. + split; auto. + exists C1. + auto with eig_db. + + apply H0; apply H1'. +Qed. + + +Lemma cap_I_r : forall {n} A, + A ∩ (I_n n) ≡ A. +Proof. intros. + rewrite cap_comm. + rewrite cap_I_l. + reflexivity. +Qed. + +(* these were origionall for gates, but I provided versions for vectors as well *) +Lemma cap_elim_l : forall {n} (g : Vector n) (A B : vecType n), + g :' A ∩ B -> g :' A. +Proof. intros n g A B H. + apply (has_type_subset _ _ A (A ∩ B)). + auto with sub_db. + apply H. +Qed. + +Lemma cap_elim_r : forall {n} (g : Vector n) (A B : vecType n), + g :' A ∩ B -> g :' B. +Proof. intros n g A B H. + apply (has_type_subset _ _ B (A ∩ B)). + auto with sub_db. + apply H. +Qed. + + + +(* another important lemma about ∩ *) +Lemma types_add : forall (n : nat) (v : Vector n) (A B : vecType n), + v :' A -> v :' B -> v :' (A ∩ B). +Proof. intros n v A B. + unfold vecHasType; intros H1 H2. + intros A0 H. + apply in_app_or in H. + destruct H as [HA | HB]. + - apply H1; apply HA. + - apply H2; apply HB. +Qed. + +(* first test of the new paradigm *) +Ltac normalize_mul := + repeat match goal with + | |- context[(?A ⊗ ?B) ⊗ ?C] => rewrite <- (tensor_assoc A B C) + end; + repeat (rewrite mul_tensor_dist by auto with sing_db); + repeat rewrite mul_assoc; + repeat ( + try rewrite <- (mul_assoc _ X' Z' _); + autorewrite with mul_db tensor_db; + try rewrite mul_assoc); auto with sing_db; auto with univ_db. + +Lemma Ysqr : Y' *' Y' = I'. Proof. normalize_mul. Qed. +Lemma XmulZ : X' *' Z' = - Z' *' X'. Proof. normalize_mul. Qed. +Lemma XmulY : X' *' Y' = i Z'. Proof. normalize_mul. Qed. +Lemma YmulX : Y' *' X' = -i Z'. Proof. normalize_mul. Qed. +Lemma ZmulY : Z' *' Y' = -i X'. Proof. normalize_mul. Qed. +Lemma YmulZ : Y' *' Z' = i X'. Proof. normalize_mul. Qed. + + +(* some more lemmas about specific vectors *) + + +(* note that vecHasType_is_vecHasType' makes this nice since *) +(* vecHasType' works well with singletons as opposed to vecHasType *) +Ltac solveType := apply vecHasType_is_vecHasType'; + simpl; unfold singVecType; apply kill_true; split; auto with wf_db; + try (exists C1; auto with eig_db; easy); + try (exists (Copp C1); auto with eig_db). + +Lemma all_hastype_I : forall (v : Vector 2), WF_Matrix v -> v :' I'. +Proof. intros. solveType. +Qed. + +Lemma p_hastype_X : ∣+⟩ :' X'. Proof. solveType. Qed. +Lemma m_hastype_X : ∣-⟩ :' X'. Proof. solveType. Qed. +Lemma O_hastype_Z : ∣0⟩ :' Z'. Proof. solveType. Qed. +Lemma i_hastype_Z : ∣1⟩ :' Z'. Proof. solveType. Qed. + +Lemma B_hastype_XX : ∣Φ+⟩ :' X' ⊗' X'. Proof. solveType. Qed. + + +Hint Resolve all_hastype_I p_hastype_X m_hastype_X O_hastype_Z i_hastype_Z B_hastype_XX : vht_db. + +(**************************************************************) +(* Defining pairHasType, which is a helper function for later *) +(**************************************************************) + +Definition pairHasType {n : nat} (p : Vector n * C) (ts: vecType n) : Prop := + forall (A : Square n), In A ts -> Eigenpair A p. + + +Lemma has_type_subset_pair : forall (n : nat) (p : Vector n * C) (t1s t2s : vecType n), + (t1s ⊆ t2s) -> pairHasType p t2s -> pairHasType p t1s. +Proof. intros n p t1s t2s. + unfold subset_gen; unfold pairHasType. + intros H H0 A H1. + apply H0; apply H; apply H1. +Qed. + + +Lemma cap_elim_l_pair : forall {n} (g : Vector n * C) (A B : vecType n), + pairHasType g (A ∩ B) -> pairHasType g A. +Proof. intros n g A B H. + apply (has_type_subset_pair _ _ A (A ∩ B)). + auto with sub_db. + apply H. +Qed. + +Lemma cap_elim_r_pair : forall {n} (g : Vector n * C) (A B : vecType n), + pairHasType g (A ∩ B) -> pairHasType g B. +Proof. intros n g A B H. + apply (has_type_subset_pair _ _ B (A ∩ B)). + auto with sub_db. + apply H. +Qed. + + +(***************************) +(* Writing actual programs *) +(***************************) + +Notation gateType n := (list (vecType n * vecType n)). + + + +Definition singGateType {n : nat} (U : Square n) (p : vecType n * vecType n) : Prop := + forall (A B : Square n), In A (fst p) -> In B (snd p) -> U × A = B × U. + +(* alternate, less powerful but more accurate definition *) +(* U : A -> B => U sends eigs of A to eigs of B *) +Definition singGateType' {n : nat} (U : Square n) (p : vecType n * vecType n) : Prop := + forall v c, pairHasType (v, c) (fst p) -> pairHasType (U × v, c) (snd p). + +Lemma sgt_implies_sgt' : forall {n} (U : Square n) (g : vecType n * vecType n), + fst g <> [] -> singGateType U g -> singGateType' U g. +Proof. intros. + unfold singGateType in H0. + unfold singGateType'. intros v c Ha B Hb. + unfold Eigenpair; simpl. + destruct (fst g) as [| A]. + - easy. + - assert (H1 : U × A = B × U). + { apply H0. left. easy. apply Hb. } + rewrite <- Mmult_assoc. + rewrite <- H1. + rewrite Mmult_assoc. + unfold pairHasType in Ha. + unfold Eigenpair in Ha. simpl in Ha. + assert (H'' : A × v = c .* v). + { apply Ha. left. easy. } + rewrite H''. + rewrite Mscale_mult_dist_r. + reflexivity. +Qed. + + +Lemma sgt'_implies_sgt : forall {n} (U : Square n) (g : vecType n * vecType n), + WF_Unitary U -> Singleton (fst g) -> (uni_vecType (fst g) /\ uni_vecType (snd g)) -> + singGateType' U g -> singGateType U g. +Proof. intros n U g H H0 [Hf Hs] H1. + apply singleton_simplify in H0; destruct H0. + unfold singGateType' in H1. + unfold singGateType. intros A B HA HB. + unfold uni_vecType in *. + assert (H': eq_eigs A (U† × B × U)). + { intros p H2 H3. destruct p. + apply eig_unit_conv; try easy. + unfold pairHasType in H1. + rewrite H0 in *. + apply (H1 m c). + unfold pairHasType. + intros. + apply in_simplify in H4. + apply in_simplify in HA. + rewrite H4, <- HA. + apply H3. + apply HB. } + apply eq_eigs_implies_eq_unit in H'. + rewrite H'. + do 2 (rewrite <- Mmult_assoc). + destruct H as [Hwf Hu]. + apply Minv_flip in Hu; auto with wf_db. + rewrite Hu, Mmult_1_l. + reflexivity. + destruct (Hs B) as [Haa _]; auto. + apply Hf; auto. + apply Mmult_unitary; auto. + apply Mmult_unitary; auto. + apply transpose_unitary; auto. +Qed. + + + + +(* as before, two defs of gateHasType that are useful in different areas *) +Definition gateHasType {n : nat} (U : Square n) (ts : gateType n) : Prop := + forall (A : vecType n * vecType n), In A ts -> singGateType' U A. + +Fixpoint gateHasType' {n : nat} (U : Square n) (ts: gateType n) : Prop := + match ts with + | [] => True + | (t :: ts') => (singGateType' U t) /\ gateHasType' U ts' + end. + +Lemma gateHasType_is_gateHasType' : forall (n : nat) (U : Square n) (A : gateType n), + gateHasType U A <-> gateHasType' U A. +Proof. intros n U A. split. + - induction A as [| h]. + * easy. + * intros H. + simpl. split. + + unfold gateHasType in H. + apply H. + simpl; left; reflexivity. + + apply IHA. + unfold gateHasType in H. + unfold gateHasType; intros. + apply H; simpl; right; apply H0. + - induction A as [| h]. + * easy. + * intros [H1 H2]. + unfold gateHasType; intros. + apply IHA in H2. + destruct H as [H3 | H4]. + rewrite <- H3; apply H1. + apply H2; apply H4. +Qed. + +(* takes two vecTypes and makes gateType *) +Definition formGateType {n : nat} (A B : vecType n) : gateType n := [(A, B)]. + +Definition gateApp {n : nat} (U A : Square n) : Square n := + U × A × U†. + +(* NOTE!! We use the second def, formGateType', here since it works better with singletons *) +Notation "U ::' F" := (gateHasType' U F) (at level 61) : heisenberg_scope. +Notation "A → B" := (formGateType A B) (at level 60, no associativity) : heisenberg_scope. +Notation "U [ A ]" := (gateApp U A) (at level 0) : heisenberg_scope. + + +Lemma type_is_app : forall (n: nat) (U A B : Square n), + WF_Unitary U -> WF_Unitary A -> WF_Unitary B -> + (U ::' ([A] → [B]) <-> U[A] = B). +Proof. intros n U A B [Huwf Hu] [Hawf Ha] [Hbwf Hb]. split. + - simpl. intros [H _]. + apply sgt'_implies_sgt in H. + unfold singGateType in H; unfold gateApp. + simpl in H. rewrite (H A B). + rewrite Mmult_assoc. + apply Minv_flip in Hu; try easy. + rewrite Hu. apply Mmult_1_r; auto. + apply transpose_unitary; auto. + split; auto. + left. easy. left. easy. + split; auto. + easy. + unfold uni_vecType. + simpl. split. + + intros A' [Ha' | F]. + rewrite <- Ha'. split; auto. + easy. + + intros B' [Hb' | F]. + rewrite <- Hb'. split; auto. + easy. + - intros. apply kill_true. + apply sgt_implies_sgt'. + easy. + unfold singGateType; unfold gateApp in H. + intros. + apply in_simplify in H0. + apply in_simplify in H1. + rewrite H0, H1. + rewrite <- H. + rewrite Mmult_assoc. + rewrite Hu. + rewrite Mmult_assoc. + rewrite Mmult_1_r; + auto. +Qed. + + +(* Gate definitions *) + +Definition H' := hadamard. +Definition S' := Phase'. +Definition T' := phase_shift (PI / 4). +Definition CNOT := cnot. + + +Definition seq {n : nat} (U1 U2 : Square n) := U2 × U1. + +Infix ";" := seq (at level 52, right associativity). + + +Lemma singleton_simplify2 : forall {n} (U A B : Square n), + singGateType U ([A], [B]) <-> U × A = B × U. +Proof. intros. + unfold singGateType. split. + - intros. apply (H A B). + simpl. left. easy. + simpl. left. easy. + - intros. simpl in *. + destruct H0 as [H0 | F]. + destruct H1 as [H1 | F']. + rewrite <- H0, <- H1; apply H. + easy. easy. +Qed. + + +(* lemmas about seq*) +Lemma app_comp : forall (n : nat) (U1 U2 A B C : Square n), + U1[A] = B -> U2[B] = C -> (U2×U1) [A] = C. +Proof. unfold gateApp. intros n U1 U2 A B C H1 H2. rewrite <- H2. rewrite <- H1. + rewrite Mmult_adjoint. do 3 rewrite <- Mmult_assoc. reflexivity. +Qed. + +Lemma SeqTypes : forall {n} (g1 g2 : Square n) (A B C : vecType n), + g1 ::' A → B -> + g2 ::' B → C -> + g1 ; g2 ::' A → C. +Proof. intros n g1 g2 A B C. + simpl. intros [HAB _] [HBC _]. + apply kill_true. + unfold singGateType'; simpl; intros. + unfold seq. rewrite (Mmult_assoc g2 g1 v). + unfold singGateType' in *; simpl in *. + apply HBC. + apply HAB. + apply H. +Qed. + + +Lemma seq_assoc : forall {n} (p1 p2 p3 : Square n) (A : gateType n), + p1 ; (p2 ; p3) ::' A <-> (p1 ; p2) ; p3 ::' A. +Proof. intros n p1 p2 p3 A. unfold seq. split. + - rewrite Mmult_assoc. easy. + - rewrite Mmult_assoc. easy. +Qed. + + +Lemma In_eq_Itensor : forall (n : nat), + n ⨂' I' = [I (2^n)]. +Proof. intros n. assert (H : n ⨂' I' = [n ⨂ I 2]). + { induction n as [| n']. + - reflexivity. + - simpl. rewrite IHn'. simpl. reflexivity. } + rewrite H. rewrite kron_n_I. + reflexivity. +Qed. + + +Lemma Types_I : forall {n} (p : Square n), WF_Matrix p -> p ::' [I n] → [I n]. +Proof. intros. + apply kill_true. + apply sgt_implies_sgt'. + easy. + unfold singGateType. + intros. + apply in_simplify in H0. + apply in_simplify in H1. + rewrite H0, H1. + rewrite Mmult_1_r, Mmult_1_l; auto. +Qed. + +(* Note that this doesn't restrict # of qubits referenced by p. *) +Lemma TypesI1 : forall (p : Square 2), WF_Matrix p -> p ::' I' → I'. +Proof. intros p. unfold I'. + apply Types_I. +Qed. + + +Lemma TypesI2 : forall (p : Square 4), WF_Matrix p -> p ::' I' ⊗' I' → I' ⊗' I'. +Proof. intros p H. + assert (H0 : I' ⊗' I' = [I 4]). + { simpl. rewrite id_kron. easy. } + rewrite H0. + apply Types_I; auto. +Qed. + + +Lemma TypesIn : forall (n : nat) (p : Square (2^n)), WF_Matrix p -> p ::' n ⨂' I' → n ⨂' I'. +Proof. intros n p H. rewrite In_eq_Itensor. + apply (@Types_I (2^n) p); auto. +Qed. + + +Hint Resolve TypesI1 TypesI2 TypesIn : base_types_db. + + +(* Formal statements of all the transformations listed in figure 1 of Gottesman*) + + + +(*********************) +(** Structural rules *) +(*********************) + + +(* Subtyping rules *) + +(* must prove same lemmas for gateTypes as for vectTypes. *) +(* Could probably find way to get rid of repeated code... *) + +Lemma has_type_subset_gate : forall (n : nat) (g : Square n) (t1s t2s : gateType n), + t1s ⊆ t2s -> g ::' t2s -> g ::' t1s. +Proof. intros n v t1s t2s H H0. + apply gateHasType_is_gateHasType'; unfold gateHasType. + apply gateHasType_is_gateHasType' in H0; unfold gateHasType in H0. + intros A H2. + apply H0. + apply H; apply H2. +Qed. + + +Definition eq_gateType {n} (T1 T2 : gateType n) := + (forall v, v ::' T1 <-> v ::' T2). + + +Infix "≡≡" := eq_gateType (at level 70, no associativity) : heisenberg_scope. + +(* will now show this is an equivalence relation *) +Lemma eq_gateType_refl : forall {n} (A : gateType n), A ≡≡ A. +Proof. intros n A. + easy. +Qed. + +Lemma eq_gateType_sym : forall {n} (A B : gateType n), A ≡≡ B -> B ≡≡ A. +Proof. intros n A B H. + unfold eq_gateType in *; intros v. + split. apply H. apply H. +Qed. + +Lemma eq_gateType_trans : forall {n} (A B C : gateType n), + A ≡≡ B -> B ≡≡ C -> A ≡≡ C. +Proof. + intros n A B C HAB HBC. + unfold eq_gateType in *. + split. + - intros. apply HBC; apply HAB; apply H. + - intros. apply HAB; apply HBC; apply H. +Qed. + + +Add Parametric Relation n : (gateType n) (@eq_gateType n) + reflexivity proved by eq_gateType_refl + symmetry proved by eq_gateType_sym + transitivity proved by eq_gateType_trans + as eq_gateType_rel. + + + + +Lemma eq_types_are_Eq_gate : forall (n : nat) (g : Square n) (T1 T2 : gateType n), + (T1 ⊆ T2 /\ T2 ⊆ T1) -> T1 ≡≡ T2. +Proof. intros n v T1 T2 [S12 S21]. + unfold eq_gateType. intros. split. + - apply has_type_subset_gate; apply S21. + - apply has_type_subset_gate; apply S12. +Qed. + + +Lemma cap_elim_l_gate : forall {n} (g : Square n) (A B : gateType n), + g ::' A ∩ B -> g ::' A. +Proof. intros n g A B H. + apply (has_type_subset_gate _ _ A (A ∩ B)). + auto with sub_db. + apply H. +Qed. + +Lemma cap_elim_r_gate : forall {n} (g : Square n) (A B : gateType n), + g ::' A ∩ B -> g ::' B. +Proof. intros n g A B H. + apply (has_type_subset_gate _ _ B (A ∩ B)). + auto with sub_db. + apply H. +Qed. + +Lemma cap_intro : forall {n} (g : Square n) (A B : gateType n), + g ::' A -> g ::' B -> g ::' A ∩ B. +Proof. intros n g A B. + induction A as [| a]. + - simpl; easy. + - simpl; intros [Ha Ha'] Hb; split. + * apply Ha. + * apply IHA. + apply Ha'. + apply Hb. +Qed. + +(* Note that both cap_elim_pair and cap_elim_gate are here. Both are necessary *) +Hint Resolve cap_elim_l_gate cap_elim_r_gate cap_elim_l_pair cap_elim_r_pair cap_intro : subtype_db. + +Lemma cap_elim : forall {n} (g : Square n) (A B : gateType n), + g ::' A ∩ B -> g ::' A /\ g ::' B. +Proof. eauto with subtype_db. Qed. + + +Lemma cap_arrow : forall {n} (g : Square n) (A B C : vecType n), + g ::' (A → B) ∩ (A → C) -> + g ::' A → (B ∩ C). +Proof. intros n g A B C [Ha [Hb _]]. + apply kill_true. + unfold singGateType' in *; simpl in *. + intros v c H B' Hb'. + apply in_app_or in Hb'; destruct Hb' as [H3 | H3]. + - apply Ha. apply H. apply H3. + - apply Hb. apply H. apply H3. +Qed. + + + +Lemma arrow_sub : forall {n} (g : Square n) (A A' B B' : vecType n), + (forall l, pairHasType l A' -> pairHasType l A) -> + (forall r, pairHasType r B -> pairHasType r B') -> + g ::' A → B -> + g ::' A' → B'. +Proof. intros n g A A' B B' Ha Hb [H _]. simpl in *. + apply kill_true. + unfold singGateType' in *; simpl in *. + intros. + apply Hb. + apply H. + apply Ha. + apply H0. +Qed. + + +Hint Resolve cap_elim cap_arrow arrow_sub : subtype_db. + + + +(* this is killed by eauto with subtype_db *) +Lemma cap_arrow_distributes : forall {n} (g : Square n) (A A' B B' : vecType n), + g ::' (A → A') ∩ (B → B') -> + g ::' (A ∩ B) → (A' ∩ B'). +Proof. + intros; apply cap_arrow. + apply cap_intro; eauto with subtype_db. +Qed. + +(* "Full explicit proof", as in Programs.v *) +Lemma cap_arrow_distributes'' : forall {n} (g : Square n) (A A' B B' : vecType n), + g ::' (A → A') ∩ (B → B') -> + g ::' (A ∩ B) → (A' ∩ B'). +Proof. + intros. + apply cap_arrow. + apply cap_intro. + - eapply arrow_sub; intros. + + apply cap_elim_l_pair in H0. apply H0. + + apply H0. + + eapply cap_elim_l_gate. apply H. + - eapply arrow_sub; intros. + + eapply cap_elim_r_pair. apply H0. + + apply H0. + + eapply cap_elim_r_gate. apply H. +Qed. + +(***************) +(* Arrow rules *) +(***************) + + + +Lemma arrow_mul : forall {n} (p : Square n) (A A' B B' : vecType n), + Singleton A -> Singleton B -> + WF_Unitary p -> + uni_vecType A -> uni_vecType A' -> + uni_vecType B -> uni_vecType B' -> + p ::' A → A' -> + p ::' B → B' -> + p ::' A *' B → A' *' B'. +Proof. intros n p A A' B B' Hsa Hsb Hup Hua Hua' Hub Hub' [Ha _] [Hb _]. + assert (Hsa' : Singleton A). { apply Hsa. } + assert (Hsb' : Singleton B). { apply Hsb. } + apply singleton_simplify in Hsa; destruct Hsa; + apply singleton_simplify in Hsb; destruct Hsb; + apply kill_true. + apply sgt_implies_sgt'. + rewrite H, H0. simpl. easy. + apply sgt'_implies_sgt in Ha. + apply sgt'_implies_sgt in Hb. + unfold singGateType in *. + intros AB A'B' H1 H2. simpl in *. + apply in_mult in H1. + apply in_mult in H2. + do 2 (destruct H1); destruct H1 as [H1 H1']; destruct H1' as [H1' H1'']. + do 2 (destruct H2); destruct H2 as [H2 H2']; destruct H2' as [H2' H2'']. + rewrite H1'', H2''. + rewrite <- Mmult_assoc. + assert (H3: p × x1 = x3 × p). + { apply Ha. apply H1. apply H2. } + assert (H4: p × x2 = x4 × p). + { apply Hb. apply H1'. apply H2'. } + rewrite H3. rewrite Mmult_assoc. + rewrite H4. rewrite <- Mmult_assoc. + reflexivity. + apply Hup. apply Hsb'. + split. apply Hub. apply Hub'. + apply Hup. apply Hsa'. + split. apply Hua. apply Hua'. +Qed. + + + +Lemma arrow_scale : forall {n} (p : Square n) (A A' : vecType n) (c : C), + c <> C0 -> p ::' A → A' -> p ::' c · A → c · A'. +Proof. intros n p A A' c H0 [H _]. + apply kill_true. + unfold singGateType' in *. + intros v x H1. simpl in *. + intros A0 H2. + unfold pairHasType in *. + apply in_scale in H2. + destruct H2 as [a' [H2 H2']]. + assert (H' : Eigenpair a' (p × v, x / c)). + { apply H. intros A1 H3. + apply (eigen_scale_div _ _ _ c). + apply H0. + assert (H' : c * (x / c) = x). + { C_field_simplify. reflexivity. apply H0. } + rewrite H'. apply H1. + apply in_scale_rev. apply H3. + apply H2. } + rewrite H2'. + assert (H'' : x = (x / c) * c). + { C_field_simplify. reflexivity. apply H0. } + rewrite H''. + apply eigen_scale. + apply H'. +Qed. + + +Lemma arrow_i : forall {n} (p : Square n) (A A' : vecType n), + p ::' A → A' -> + p ::' i A → i A'. +Proof. unfold i. intros. + apply arrow_scale. + apply C0_snd_neq. simpl. easy. + apply H. +Qed. + +Lemma arrow_neg : forall {n} (p : Square n) (A A' : vecType n), + p ::' A → A' -> + p ::' -A → -A'. +Proof. unfold neg. intros. + apply arrow_scale. + rewrite <- Cexp_PI. + apply Cexp_nonzero. + apply H. +Qed. + + + +Lemma eq_arrow_r : forall {n} (g : Square n) (A B B' : vecType n), + g ::' A → B -> + B = B' -> + g ::' A → B'. +Proof. intros; subst; easy. Qed. + + + +(*****************************) +(** Typing Rules for Tensors *) +(*****************************) + +Local Open Scope nat_scope. + + +Definition vecTypeT (len : nat) := (list (vecType 2)). + +Definition vecTypeT' := (list (vecType 2)). + + +Definition X'' : vecTypeT 1 := [X']. +Definition Z'' : vecTypeT 1 := [Z']. +Definition I'' : vecTypeT 1 := [I']. + + +Definition tensorT {n m} (A : vecTypeT n) (B : vecTypeT m) : vecTypeT (n + m) := A ++ B. + +Fixpoint mulT' (A B : vecTypeT') : vecTypeT' := + match A with + | [] => B + | (a :: As) => + match B with + | [] => A + | (b :: Bs) => (a *' b :: mulT' As Bs) + end + end. + + +Definition mulT {n : nat} (A B : vecTypeT n) : vecTypeT n := mulT' A B. + + +Definition scaleT (c : C) {n : nat} (A : vecTypeT n) : vecTypeT n := + match A with + | [] => [] + | (h :: t) => (c · h :: t) + end. + + + +Definition formGateTypeT {n : nat} (A B : vecTypeT n) : gateType n := [(⨂' A, ⨂' B)]. + + +Infix "'⊗'" := tensorT (at level 51, right associativity) : heisenberg_scope. +Notation "A →' B" := (formGateTypeT A B) (at level 60, no associativity) : heisenberg_scope. + + +Definition WF_vtt {len : nat} (vt : vecTypeT len) := length vt = len. + + + +(* defining program application *) +Definition prog_smpl_app (prg_len : nat) (U : Square 2) (bit : nat) : Square (2^prg_len) := + match bit I (2^bit) ⊗ U ⊗ I (2^(prg_len - bit - 1)) + | false => I (2^prg_len) + end. + + + +Lemma unit_prog_smpl_app : forall (prg_len : nat) (U : Square 2) (bit : nat), + WF_Unitary U -> WF_Unitary (prog_smpl_app prg_len U bit). +Proof. intros. + unfold prog_smpl_app. + destruct (bit I (2^prg_len) + | true => + match (ctrl I (2^ctrl) ⊗ + (∣0⟩⟨0∣ ⊗ I (2^(targ - ctrl)) .+ + ∣1⟩⟨1∣ ⊗ I (2^(targ - ctrl - 1)) ⊗ U) ⊗ I (2^(prg_len - targ - 1)) + | false => I (2^targ) ⊗ + (I (2^(ctrl - targ)) ⊗ ∣0⟩⟨0∣ .+ + U ⊗ I (2^(ctrl - targ - 1)) ⊗ ∣1⟩⟨1∣) ⊗ I (2^(prg_len - ctrl - 1)) + end + end. + + + +Lemma unit_proj : forall (n : nat) (U : Square 2), + n <> 0 -> WF_Unitary U -> WF_Unitary (∣0⟩⟨0∣ ⊗ I (2^n) .+ ∣1⟩⟨1∣ ⊗ I (2^(n - 1)) ⊗ U). +Proof. intros. + destruct H0 as [Huwf H0]. + split; auto with wf_db. + rewrite Mplus_adjoint. + rewrite kron_adjoint. + assert (H1 : ∣0⟩⟨0∣ † = ∣0⟩⟨0∣). + { lma'. } + assert (H1' : ∣1⟩⟨1∣ † = ∣1⟩⟨1∣). + { lma'. } + rewrite H1. + rewrite id_adjoint_eq. + assert (H' : n - 0 = n). { nia. } + assert (H2 : 2 * 2^(n - 1) = 2^n). + { rewrite (easy_pow3 n 0); try nia. + rewrite H'. simpl. nia. } + assert (H2' : 2^(n - 1)*2 = 2^n). { rewrite mult_comm. apply H2. } + assert (H3 : ( ∣1⟩⟨1∣ ⊗ I (2 ^ (n - 1)) ⊗ U ) † = ∣1⟩⟨1∣ ⊗ I (2 ^ (n - 1)) ⊗ U † ). + { rewrite H2. + rewrite kron_adjoint. + rewrite <- H2. + rewrite kron_adjoint. + rewrite id_adjoint_eq. + rewrite H1'. + reflexivity. } + rewrite easy_pow6; try easy. + rewrite H3. + rewrite Mmult_plus_distr_l. + do 2 (rewrite Mmult_plus_distr_r). + rewrite kron_mixed_product. + rewrite <- easy_pow6; try easy. + do 2 (rewrite kron_mixed_product). + assert (H4 : ∣0⟩⟨0∣ × ∣0⟩⟨0∣ = ∣0⟩⟨0∣). { lma'. } + rewrite H4. rewrite Mmult_1_l; try auto with wf_db. + assert (H4' : ∣1⟩⟨1∣ × ∣1⟩⟨1∣ = ∣1⟩⟨1∣). { lma'. } + rewrite H4'. rewrite Mmult_1_l; try auto with wf_db. + rewrite kron_assoc; auto with wf_db. + rewrite H2'. + rewrite kron_mixed_product; auto with wf_db. + rewrite kron_assoc; auto with wf_db. + rewrite H2'. rewrite kron_mixed_product; auto with wf_db. + assert (H5 : ∣1⟩⟨1∣ × ∣0⟩⟨0∣ = Zero). { lma'. } + assert (H5' : ∣0⟩⟨0∣ × ∣1⟩⟨1∣ = Zero). { lma'. } + rewrite H5, H5', kron_0_l, kron_0_l, H0, Mplus_0_r, Mplus_0_l. + rewrite kron_assoc, id_kron; auto with wf_db. + replace (2^ (n - 1) * 2) with (2^n) by lia. + rewrite <- kron_plus_distr_r. + assert (H6 : ∣0⟩⟨0∣ .+ ∣1⟩⟨1∣ = I 2). { lma'. } + rewrite H6. + rewrite id_kron. + reflexivity. +Qed. + + +Lemma unit_proj2 : forall (n : nat) (U : Square 2), + n <> 0 -> WF_Unitary U -> + WF_Unitary (I (2 ^ n) ⊗ ∣0⟩⟨0∣ .+ U ⊗ I (2 ^ (n - 1)) ⊗ ∣1⟩⟨1∣). +Proof. intros. + destruct H0 as [Huwf H0]. + split; auto with wf_db. + rewrite Mplus_adjoint. + rewrite kron_adjoint. + assert (H1 : ∣0⟩⟨0∣ † = ∣0⟩⟨0∣). + { lma'. } + assert (H1' : ∣1⟩⟨1∣ † = ∣1⟩⟨1∣). + { lma'. } + rewrite H1. + rewrite id_adjoint_eq. + assert (H' : n - 0 = n). { nia. } + assert (H2 : 2 * 2^(n - 1) = 2^n). + { rewrite (easy_pow3 n 0); try nia. + rewrite H'. simpl. nia. } + assert (H2' : 2^(n - 1)*2 = 2^n). { rewrite mult_comm. apply H2. } + assert (H3 : (U ⊗ I (2 ^ (n - 1)) ⊗ ∣1⟩⟨1∣) † = U † ⊗ I (2 ^ (n - 1)) ⊗ ∣1⟩⟨1∣). + { rewrite H2. + rewrite kron_adjoint. + rewrite <- H2. + rewrite kron_adjoint. + rewrite id_adjoint_eq. + rewrite H1'. + reflexivity. } + rewrite easy_pow6'; try easy. + rewrite H3. + rewrite Mmult_plus_distr_l. + do 2 (rewrite Mmult_plus_distr_r). + rewrite kron_mixed_product. + rewrite <- easy_pow6'; try easy. + do 2 (rewrite kron_mixed_product). + assert (H4 : ∣0⟩⟨0∣ × ∣0⟩⟨0∣ = ∣0⟩⟨0∣). { lma'. } + rewrite H4. rewrite Mmult_1_l; try auto with wf_db. + assert (H4' : ∣1⟩⟨1∣ × ∣1⟩⟨1∣ = ∣1⟩⟨1∣). { lma'. } + rewrite H4'. rewrite Mmult_1_l; try auto with wf_db. + rewrite (kron_mixed_product' (2*2^(n-1)) (2*2^(n-1)) _ _ 2 2 _ _ + (2^n*2) (2^n*2) (2^n*2) _ _ _ _); try easy; + try (rewrite H2; easy). + rewrite (kron_mixed_product' (2^n) (2^n) (2*2^(n-1)) (2*2^(n-1)) 2 2 _ _ + (2^n*2) (2^n*2) (2^n*2) _ _ _ _); try easy; + try (rewrite H2; easy). + assert (H5 : ∣1⟩⟨1∣ × ∣0⟩⟨0∣ = Zero). { lma'. } + assert (H5' : ∣0⟩⟨0∣ × ∣1⟩⟨1∣ = Zero). { lma'. } + rewrite H5, H5'. + do 2 (rewrite kron_0_r). + rewrite H0. + rewrite id_kron. + rewrite H2. + rewrite Mplus_0_l. + rewrite Mplus_0_r. + rewrite <- kron_plus_distr_l. + assert (H6 : ∣0⟩⟨0∣ .+ ∣1⟩⟨1∣ = I 2). { lma'. } + rewrite H6. + rewrite id_kron. + reflexivity. +Qed. + + +Lemma unit_prog_ctrl_app : forall (prg_len : nat) (U : Square 2) (ctrl targ : nat), + WF_Unitary U -> WF_Unitary (prog_ctrl_app prg_len U ctrl targ). +Proof. intros. + unfold prog_ctrl_app. + bdestruct (ctrl =? targ). + - rewrite andb_false_r. + auto with unit_db. + - bdestruct (ctrl uni_vecType a) -> (forall b, In b B -> uni_vecType b) + -> uni_vecType a -> + ⨂' (A ++ [a] ++ B) = (⨂' A) ⊗' a ⊗' (⨂' B). +Proof. induction A as [| h]. + - intros. + apply univ_tensor_list in H0. + rewrite big_tensor_1_l; auto with univ_db. + - intros. simpl. + rewrite cons_conc. + rewrite IHA; auto with univ_db. + assert (H': forall (n : nat), 2^n + (2^n + 0) = 2 * 2^n). { nia. } + repeat (rewrite H'). + rewrite <- tensor_assoc; auto with univ_db. + rewrite length_change. + reflexivity. + apply H; left; auto. + apply univ_tensor_list; auto. + all : intros; try (apply H; right; easy). + apply univ_tensor_list in H0. + auto with univ_db. +Qed. + + + +Lemma nth_tensor_inc : forall (n len : nat) (A : vecTypeT len), + (forall a, In a A -> uni_vecType a) -> + n < len -> WF_vtt A -> ⨂' A = (⨂' (firstn n A)) ⊗' (nth n A I') ⊗' (⨂' (skipn (S n) A)). +Proof. intros. + rewrite <- (@big_tensor_simpl n (len - n) (firstn n A) (skipn (S n) A) (nth n A I')). + rewrite <- nth_inc. + reflexivity. + rewrite H1. + assumption. + all : intros; apply H. + - rewrite <- (firstn_skipn n). + apply in_or_app. + auto. + - rewrite <- (firstn_skipn (S n)). + apply in_or_app. + auto. + - apply nth_In. + rewrite H1; auto. +Qed. + + +Lemma switch_tensor_inc : forall (n len : nat) (A : vecTypeT len) (x : vecType 2), + (forall a, In a A -> uni_vecType a) -> uni_vecType x -> + n < len -> WF_vtt A -> ⨂' (switch A x n) = (⨂' (firstn n A)) ⊗' x ⊗' (⨂' (skipn (S n) A)). +Proof. intros. + rewrite <- (@big_tensor_simpl n (len - n) (firstn n A) (skipn (S n) A) x); auto. + rewrite <- switch_inc. + reflexivity. + rewrite H2. + assumption. + all : intros; apply H. + - rewrite <- (firstn_skipn n). + apply in_or_app. + auto. + - rewrite <- (firstn_skipn (S n)). + apply in_or_app. + auto. +Qed. + + +Lemma sgt'_reduce_smpl : forall {n m : nat} (u : Square 2) (a b : vecType 2) + (A : vecType n) (B : vecType m), + Singleton A -> Singleton B -> Singleton a -> Singleton b -> + WF_Unitary u -> uni_vecType a -> uni_vecType b -> + uni_vecType A -> uni_vecType B -> + singGateType' u (a, b) -> + singGateType' ((I n) ⊗ u ⊗ (I m)) (A ⊗' a ⊗' B, A ⊗' b ⊗' B). +Proof. intros n m u a b A B HSA HSB HSa HSb Huu Hua Hub HuA HuB Hsgt. + apply singleton_simplify in HSA; + destruct HSA as [A' HSA]; + apply singleton_simplify in HSB; + destruct HSB as [B' HSB]; + apply singleton_simplify in HSa; + destruct HSa as [a' HSa]; + apply singleton_simplify in HSb; + destruct HSb as [b' HSb]; + rewrite HSA, HSB, HSa, HSb in *. + apply sgt_implies_sgt'; try easy. + apply sgt'_implies_sgt in Hsgt; try easy. + unfold singGateType in *. + intros. + simpl in *; + destruct H as [H | F]; + destruct H0 as [H0 | F0]; try easy. + rewrite <- H, <- H0. + rewrite kron_assoc. + assert (H' : m + (m + 0) = 2 * m). { nia. } + assert (H'' : (n * 2) * m = n * (2 * m)). { nia. } + repeat (rewrite H'). repeat (rewrite H''). + do 4 (rewrite kron_mixed_product). + repeat rewrite Mmult_1_l, Mmult_1_r. + rewrite (Hsgt a' b'); + try easy; + try (left; easy). + all : auto with wf_db; + try (apply HuB; left; auto); try (apply HuA; left; auto). + apply Huu. +Qed. + + +Lemma tensor_smpl : forall (prg_len bit : nat) (g : Square 2) + (A : vecTypeT prg_len) (a : vecType 2), + (forall a : vecType 2, In a A -> uni_vecType a) -> + Singleton (⨂' A) -> Singleton a -> + WF_Unitary g -> uni_vecType (nth bit A I') -> uni_vecType a -> + bit < prg_len -> WF_vtt A -> + g ::' ((nth bit A I') → a) -> + (prog_smpl_app prg_len g bit) ::' A →' (switch A a bit). +Proof. intros prg_len bit g A a Huvt SA Sa Hug Hunb Hua Hbpl Hwf H. + simpl. + rewrite (nth_tensor_inc bit prg_len A); try easy. + rewrite (switch_tensor_inc bit prg_len A a); try easy. + unfold prog_smpl_app. + apply kill_true. + repeat (rewrite firstn_length_le). + repeat (rewrite skipn_length'). + repeat (rewrite switch_len). + unfold WF_vtt in Hwf. + rewrite Hwf in *. + repeat (rewrite (easy_pow3 prg_len bit)); try easy. + bdestruct (bit uni_vecType a). + { intros; apply Huvt. + rewrite <- (firstn_skipn bit). + apply in_or_app; auto. } + apply univ_tensor_list in H'. + rewrite firstn_length_le in H'. + auto. rewrite Hwf; nia. + - assert (H' : forall a : vecType 2, In a (skipn (S bit) A) -> uni_vecType a). + { intros; apply Huvt. + rewrite <- (firstn_skipn (S bit)). + apply in_or_app; auto. } + apply univ_tensor_list in H'. + rewrite skipn_length, Hwf in H'. + replace ((prg_len - bit) - 1) with (prg_len - (S bit)) by lia. + auto. + - apply H. + - rewrite Hwf; lia. +Qed. + + + +Lemma CX_is_CNOT : (∣0⟩⟨0∣ ⊗ (I 2) .+ ∣1⟩⟨1∣ ⊗ σx) = cnot. +Proof. lma'. +Qed. + +Lemma CX_is_NOTC : ((Matrix.I 2) ⊗ ∣0⟩⟨0∣ .+ σx ⊗ ∣1⟩⟨1∣) = notc. +Proof. lma'. +Qed. + + +Definition CZ := (∣0⟩⟨0∣ ⊗ (I 2) .+ ∣1⟩⟨1∣ ⊗ σz). + + +Lemma WF_CZ : WF_Matrix CZ. +Proof. unfold CZ. + auto with wf_db. +Qed. + +Hint Resolve WF_CZ : wf_db. + +Lemma unit_CZ : WF_Unitary CZ. +Proof. split; auto with wf_db. + lma'. Qed. + + +Hint Resolve unit_CZ : unit_db. + + + +Lemma adj_ctrlX_is_cnot : forall (prg_len ctrl : nat), + 1 + ctrl < prg_len -> + prog_ctrl_app prg_len σx ctrl (1 + ctrl) = + I (2^ctrl) ⊗ cnot ⊗ I (2^(prg_len - ctrl - 2)). +Proof. intros; unfold prog_ctrl_app. + bdestruct_all. + replace (1 + ctrl - ctrl) with 1 by lia. + simpl. + assert (H' : (∣0⟩⟨0∣ ⊗ I 2 .+ ∣1⟩⟨1∣ ⊗ I 1 ⊗ σx) = cnot). + { lma'. } + assert (H'' : forall (n m : nat) (a b : Square n) (c d : Square m), + a = b -> c = d -> a ⊗ c = b ⊗ d). + { intros. rewrite H4, H5; easy. } + replace (prg_len - ctrl - 2) with (prg_len - S ctrl - 1) by lia. + apply H''; try easy. + apply H''; try easy. +Qed. + + +Lemma adj_ctrlX_is_notc : forall (prg_len targ : nat), + 1 + targ < prg_len -> + prog_ctrl_app prg_len σx (1 + targ) targ = + I (2^targ) ⊗ notc ⊗ I (2^(prg_len - targ - 2)). +Proof. intros; unfold prog_ctrl_app. + bdestruct_all. + replace (1 + targ - targ) with 1 by lia. + simpl. + assert (H' : (I 2 ⊗ ∣0⟩⟨0∣ .+ σx ⊗ I 1 ⊗ ∣1⟩⟨1∣) = notc). + { lma'. } + assert (H'' : forall (n m : nat) (a b : Square n) (c d : Square m), + a = b -> c = d -> a ⊗ c = b ⊗ d). + { intros. rewrite H4, H5; easy. } + replace (prg_len - targ - 2) with (prg_len - S targ - 1) by lia. + apply H''; try easy. + apply H''; try easy. +Qed. + + +Lemma adj_ctrlX_is_cnot1 : prog_ctrl_app 2 σx 0 1 = cnot. +Proof. rewrite adj_ctrlX_is_cnot; try lia. + rewrite Nat.sub_0_r, Nat.sub_diag, Nat.pow_0_r. + rewrite kron_1_l, kron_1_r; auto with wf_db. +Qed. + + +Lemma adj_ctrlX_is_notc1 : prog_ctrl_app 2 σx 1 0 = notc. +Proof. rewrite adj_ctrlX_is_notc; try lia. + rewrite Nat.sub_0_r, Nat.sub_diag, Nat.pow_0_r. + rewrite kron_1_l, kron_1_r; auto with wf_db. +Qed. + + + +(* switched order of 2 by 2 kron products. *) +(* Useful for showing that effect of cnot on a ⊗ b *) +Definition switch_kron_order (A : Square 4) : Square 4 := + fun x y => + match (x, y) with + | (0, 0) => A 0 0 + | (0, 1) => A 0 2 + | (0, 2) => A 0 1 + | (0, 3) => A 0 3 + | (1, 0) => A 2 0 + | (1, 1) => A 2 2 + | (1, 2) => A 2 1 + | (1, 3) => A 2 3 + | (2, 0) => A 1 0 + | (2, 1) => A 1 2 + | (2, 2) => A 1 1 + | (2, 3) => A 1 3 + | (3, 0) => A 3 0 + | (3, 1) => A 3 2 + | (3, 2) => A 3 1 + | (3, 3) => A 3 3 + | _ => C0 + end. + +Lemma WF_sko : forall A, WF_Matrix (switch_kron_order A). +Proof. unfold WF_Matrix; intros. + destruct H. + - do 4 (destruct x; try lia); easy. + - do 4 (destruct y; try lia). + do 4 (destruct x; try easy). +Qed. + +Hint Resolve WF_sko : wf_db. + +Lemma sko_twice_id : forall (A : Square 4), + WF_Matrix A -> switch_kron_order (switch_kron_order A) = A. +Proof. intros. + apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv. intros. + unfold switch_kron_order. + do 4 (destruct i0; + try (do 4 (destruct j; try lca); lia)). + lia. +Qed. + + +Lemma Mmult_sko : forall (A B : Square 4), switch_kron_order (A × B) = + switch_kron_order A × switch_kron_order B. +Proof. intros. + apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv. intros. + unfold switch_kron_order, Mmult. + do 4 (destruct i0; + try (do 4 (destruct j; try lca); lia)). +Qed. + + +Lemma Mplus_sko : forall (A B : Square 4), switch_kron_order (A .+ B) = + switch_kron_order A .+ switch_kron_order B. +Proof. intros. + apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv. intros. + unfold switch_kron_order, Mplus. + do 4 (destruct i0; + try (do 4 (destruct j; try lca); lia)). +Qed. + +Lemma kron_sko_verify : forall (a b : Square 2), + WF_Matrix a -> WF_Matrix b -> + switch_kron_order (a ⊗ b) = b ⊗ a. +Proof. intros. + apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv. intros. + unfold switch_kron_order, kron. + do 4 (destruct i0; + try (do 4 (destruct j; try lca); lia)). + lia. +Qed. + +Lemma notc_sko_cnot : switch_kron_order cnot = notc. +Proof. rewrite <- CX_is_NOTC, <- CX_is_CNOT. + rewrite Mplus_sko, kron_sko_verify, kron_sko_verify; auto with wf_db. +Qed. + +Lemma cnot_sko_notc : switch_kron_order notc = cnot. +Proof. rewrite <- CX_is_NOTC, <- CX_is_CNOT. + rewrite Mplus_sko, kron_sko_verify, kron_sko_verify; auto with wf_db. +Qed. + + +Lemma notc_conv : forall (a a' b b' : Square 2), + WF_Matrix a -> WF_Matrix a' -> WF_Matrix b -> WF_Matrix b' -> + notc × (a ⊗ b) = (a' ⊗ b') × notc -> + cnot × (b ⊗ a) = (b' ⊗ a') × cnot. +Proof. intros. + assert (H4: forall a a', a = a' -> switch_kron_order a = switch_kron_order a'). + { intros. rewrite H4; easy. } + apply H4 in H3. + do 2 rewrite Mmult_sko, kron_sko_verify in H3; auto. + rewrite cnot_sko_notc in H3; easy. +Qed. + +Lemma cnot_conv : forall (a a' b b' : Square 2), + WF_Matrix a -> WF_Matrix a' -> WF_Matrix b -> WF_Matrix b' -> + cnot × (a ⊗ b) = (a' ⊗ b') × cnot -> + notc × (b ⊗ a) = (b' ⊗ a') × notc. +Proof. intros. + assert (H4: forall a a', a = a' -> switch_kron_order a = switch_kron_order a'). + { intros. rewrite H4; easy. } + apply H4 in H3. + do 2 rewrite Mmult_sko, kron_sko_verify in H3; auto. + rewrite notc_sko_cnot in H3; easy. +Qed. + + +Lemma kron_breakdown1 : forall (a a' b b' : Square 2), + WF_Matrix a -> WF_Matrix a' -> WF_Matrix b -> WF_Matrix b' -> + a ⊗ b = a' ⊗ b' -> + (forall i j k l : nat, ((a i j) * (b k l) = (a' i j) * (b' k l))%C). +Proof. intros a a' b b' H H0 H1 H2 H3 i j k l. + bdestruct (i WF_Matrix a' -> WF_Matrix b -> WF_Matrix b' -> + WF_Matrix c -> WF_Matrix c' -> WF_Matrix d -> WF_Matrix d' -> + a ⊗ b .+ c ⊗ d = a' ⊗ b' .+ c' ⊗ d' -> + (forall i j k l : nat, ((a i j) * (b k l) + (c i j) * (d k l) = + (a' i j) * (b' k l) + (c' i j) * (d' k l))%C). +Proof. intros a a' b b' c c' d d' H H0 H1 H2 H3 H4 H5 H6 H7 i j k l. + bdestruct (i WF_Matrix a' -> WF_Matrix b -> WF_Matrix b' -> + WF_Matrix C -> + a ⊗ b = a' ⊗ b' -> C = C' -> + a ⊗ C ⊗ b = a' ⊗ C' ⊗ b'. +Proof. intros; subst. + prep_matrix_equality. + unfold kron. + rewrite Cmult_comm, Cmult_assoc. + rewrite (Cmult_comm _ (b' _ _)), Cmult_assoc. + apply Cmult_simplify; try easy. + rewrite Cmult_comm, (Cmult_comm (b' _ _)). + apply kron_breakdown1; auto. +Qed. + + + + +Lemma kron_rearrange2 : forall {n} (a a' b b' c c' d d' : Square 2) (C : Square n), + WF_Matrix a -> WF_Matrix a' -> WF_Matrix b -> WF_Matrix b' -> + WF_Matrix c -> WF_Matrix c' -> WF_Matrix d -> WF_Matrix d' -> + WF_Matrix C -> + a ⊗ b .+ c ⊗ d = a' ⊗ b' .+ c' ⊗ d' -> + a ⊗ C ⊗ b .+ c ⊗ C ⊗ d = a' ⊗ C ⊗ b' .+ c' ⊗ C ⊗ d'. +Proof. intros. + apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv, kron, Mplus; intros i j H9 H10. + rewrite Cmult_comm, (Cmult_comm _ (d _ _)), + (Cmult_comm _ (b' _ _)), (Cmult_comm _ (d' _ _)). + do 4 rewrite Cmult_assoc. + do 2 rewrite <- Cmult_plus_distr_r. + apply Cmult_simplify; try easy. + rewrite (Cmult_comm (b _ _)), (Cmult_comm (b' _ _)), + (Cmult_comm (d _ _)), (Cmult_comm (d' _ _)). + apply kron_breakdown2; easy. +Qed. + +Lemma cnot_conv_inc : forall {n} (a a' b b' : Square 2) (C C' : Square (2^n)), + WF_Matrix a -> WF_Matrix a' -> WF_Matrix b -> WF_Matrix b' -> + WF_Matrix C -> + cnot × (a ⊗ b) = (a' ⊗ b') × cnot -> C = C' -> + @Mmult (2 * 2^n * 2) (2 * 2^n * 2) (2 * 2^n * 2) + (∣0⟩⟨0∣ ⊗ Matrix.I (2 * 2 ^ n) .+ ∣1⟩⟨1∣ ⊗ Matrix.I (2 ^ n) ⊗ σx) (a ⊗ C ⊗ b) = + (a' ⊗ C' ⊗ b') × (∣0⟩⟨0∣ ⊗ Matrix.I (2 * 2 ^ n) .+ ∣1⟩⟨1∣ ⊗ Matrix.I (2 ^ n) ⊗ σx). +Proof. intros; subst. + do 2 replace (2 * (2 * 2^n)) with (2 * 2^n * 2) by lia. + rewrite Mmult_plus_distr_r, Mmult_plus_distr_l. + replace (2 * 2 ^ n) with (2 ^ n * 2) by lia. + rewrite <- id_kron. + rewrite <- kron_assoc; auto with wf_db. + repeat rewrite kron_mixed_product. + replace (2 ^ n * 2) with (2 * 2 ^ n) by lia. + repeat rewrite kron_mixed_product. + rewrite Mmult_1_l, Mmult_1_r; auto. + assert (H' : cnot = ∣0⟩⟨0∣ ⊗ Matrix.I 2 .+ ∣1⟩⟨1∣ ⊗ σx). + { lma'. } + rewrite H' in H4. + rewrite Mmult_plus_distr_r, Mmult_plus_distr_l in H4. + repeat rewrite kron_mixed_product in H4. + apply kron_rearrange2; auto with wf_db. +Qed. + + + +Ltac solve_gate_type := + repeat match goal with + | |- singGateType' ?U ?g /\ _ => split + | |- ?g <> [] => easy + | |- singGateType' ?U ?g => apply sgt_implies_sgt' + | |- singGateType ?U ?g => simpl; apply singleton_simplify2; lma' + | |- _ => try easy + end. + + +Lemma HTypes : H' ::' (Z' → X') ∩ (X' → Z'). +Proof. simpl. unfold Z', X', prog_smpl_app. + solve_gate_type. +Qed. + +Lemma HTypes' : H' ::' (Z'' →' X'') ∩ (X'' →' Z''). +Proof. simpl. + repeat (rewrite kron_1_r). + solve_gate_type. +Qed. + + +Lemma STypes : (prog_smpl_app 1 S' 0) ::' (X' → Y') ∩ (Z' → Z'). +Proof. simpl. unfold Z', X', prog_smpl_app. + solve_gate_type. +Qed. + +Lemma CNOTTypes : (prog_ctrl_app 2 σx 0 1) ::' (X' ⊗' I' → X' ⊗' X') ∩ (I' ⊗' X' → I' ⊗' X') ∩ + (Z' ⊗' I' → Z' ⊗' I') ∩ (I' ⊗' Z' → Z' ⊗' Z'). +Proof. rewrite adj_ctrlX_is_cnot1. + simpl. unfold X', I', Z'. + solve_gate_type. +Qed. + + +Lemma CNOTTypes' : cnot ::' (X' ⊗' I' → X' ⊗' X') ∩ (I' ⊗' X' → I' ⊗' X') ∩ + (Z' ⊗' I' → Z' ⊗' I') ∩ (I' ⊗' Z' → Z' ⊗' Z'). +Proof. simpl. unfold X', I', Z'. + solve_gate_type. +Qed. + +Lemma CZTypes' : CZ ::' (X' ⊗' I' → X' ⊗' Z') ∩ (I' ⊗' X' → Z' ⊗' X') ∩ + (Z' ⊗' I' → Z' ⊗' I') ∩ (I' ⊗' Z' → I' ⊗' Z'). +Proof. simpl. unfold X', I', Z'. + solve_gate_type. +Qed. + + + +(* T only takes Z → Z *) +Lemma TTypes : T' ::' (Z' → Z'). +Proof. simpl. unfold T', Z'. + solve_gate_type. +Qed. + +Hint Resolve HTypes HTypes' STypes TTypes CNOTTypes CNOTTypes' CZTypes' : base_types_db. +Hint Resolve cap_elim_l_gate cap_elim_r_gate : base_types_db. + +Hint Resolve HTypes STypes TTypes CNOTTypes : typing_db. +Hint Resolve cap_intro cap_elim_l cap_elim_r : typing_db. +Hint Resolve SeqTypes : typing_db. + + +Definition appH (len bit : nat) := prog_smpl_app len H' bit. +Definition appCNOT (len ctrl targ : nat) := prog_ctrl_app len σx ctrl targ. +Definition appCZ (len ctrl targ : nat) := appH len targ ; appCNOT len ctrl targ ; appH len targ. + + +Definition bell00 : Square 16 := (prog_smpl_app 4 H' 2); (prog_ctrl_app 4 σx 2 3). + +Definition encode : Square 16 := (prog_ctrl_app 4 σz 0 2); (prog_ctrl_app 4 σx 1 2). + +Definition decode : Square 16 := (prog_ctrl_app 4 σx 2 3); (prog_smpl_app 4 H' 2). + +Definition superdense := bell00 ; encode; decode. + + + diff --git a/Matrix.v b/Matrix.v index 2baac6a..48ad1c2 100644 --- a/Matrix.v +++ b/Matrix.v @@ -8,6 +8,36 @@ Require Import List. (* TODO: Use matrix equality everywhere, declare equivalence relation *) (* TODO: Make all nat arguments to matrix lemmas implicit *) +<<<<<<< HEAD +======= +Local Open Scope nat_scope. + +(* Some prelim lemmas. Should probably be moved *) +Lemma easy_sub : forall (n : nat), S n - 1 = n. Proof. lia. Qed. + + +Lemma Csum_simplify : forall (a b c d : C), a = b -> c = d -> (a + c = b + d)%C. +Proof. intros. + rewrite H, H0; easy. +Qed. + + +Lemma Cmult_simplify : forall (a b c d : C), a = b -> c = d -> (a * c = b * d)%C. +Proof. intros. + rewrite H, H0; easy. +Qed. + + +Lemma sqrt_1_unique : forall x, √ x = 1%R -> x = 1%R. +Proof. intros. assert (H' := H). unfold sqrt in H. destruct (Rcase_abs x). + - assert (H0: 1%R <> 0%R). { apply R1_neq_R0. } + rewrite H in H0. easy. + - rewrite <- (sqrt_def x). rewrite H'. lra. + apply Rge_le. easy. +Qed. + + +>>>>>>> Heisenberg-Foundations/main (*******************************************) (** Matrix Definitions and Infrastructure **) (*******************************************) @@ -141,7 +171,10 @@ Definition I (n : nat) : Square n := (* Optional coercion to scalar (should be limited to 1 × 1 matrices): Definition to_scalar (m n : nat) (A: Matrix m n) : C := A 0 0. +<<<<<<< HEAD +======= +>>>>>>> Heisenberg-Foundations/main Coercion to_scalar : Matrix >-> C. *) @@ -255,6 +288,38 @@ Ltac lma := destruct_m_eq; lca. +<<<<<<< HEAD +======= + + +Ltac solve_end := + match goal with + | H : lt _ O |- _ => apply Nat.nlt_0_r in H; contradict H + end. + +Ltac by_cell := + intros; + let i := fresh "i" in + let j := fresh "j" in + let Hi := fresh "Hi" in + let Hj := fresh "Hj" in + intros i j Hi Hj; try solve_end; + repeat (destruct i as [|i]; simpl; [|apply lt_S_n in Hi]; try solve_end); clear Hi; + repeat (destruct j as [|j]; simpl; [|apply lt_S_n in Hj]; try solve_end); clear Hj. + + + +Ltac lma' := + apply mat_equiv_eq; + repeat match goal with + | [ |- WF_Matrix (?A) ] => auto with wf_db (* (try show_wf) *) + | [ |- mat_equiv (?A) (?B) ] => by_cell; try lca + end. + + + + +>>>>>>> Heisenberg-Foundations/main (******************************) (** Proofs about finite sums **) (******************************) @@ -457,6 +522,28 @@ Proof. apply Rplus_le_compat; easy. Qed. +<<<<<<< HEAD +======= + +Lemma Csum_gt_0 : forall f n, (forall x, 0 <= fst (f x)) -> + (exists y : nat, (y < n)%nat /\ 0 < fst (f y)) -> + 0 < fst (Csum f n). +Proof. + intros f n H [y [H0 H1]]. + induction n. + - simpl. lia. + - simpl in *. + bdestruct (y >>>>>> Heisenberg-Foundations/main Lemma Csum_member_le : forall (f : nat -> C) (n : nat), (forall x, 0 <= fst (f x)) -> (forall x, (x < n)%nat -> fst (f x) <= fst (Csum f n)). Proof. @@ -477,15 +564,135 @@ Proof. apply Rplus_le_compat. apply Csum_ge_0; easy. lra. +<<<<<<< HEAD Qed. +======= +Qed. + +Lemma Csum_squeeze : forall (f : nat -> C) (n : nat), + (forall x, (0 <= fst (f x)))%R -> Csum f n = C0 -> + (forall x, (x < n)%nat -> fst (f x) = fst C0). +Proof. intros. + assert (H2 : (forall x, (x < n)%nat -> (fst (f x) <= 0)%R)). + { intros. + replace 0%R with (fst (C0)) by easy. + rewrite <- H0. + apply Csum_member_le; try easy. } + assert (H3 : forall r : R, (r <= 0 -> 0 <= r -> r = 0)%R). + intros. lra. + simpl. + apply H3. + apply H2; easy. + apply H. +Qed. + + +Lemma Csum_snd_0 : forall n f, (forall x, snd (f x) = 0) -> snd (Csum f n) = 0. +Proof. intros. induction n. + - reflexivity. + - rewrite <- Csum_extend_r. + unfold Cplus. simpl. rewrite H, IHn. + lra. +Qed. + + +Lemma Csum_comm : forall f g n, + (forall c1 c2 : C, g (c1 + c2) = g c1 + g c2) -> + Csum (fun x => g (f x)) n = g (Csum f n). +Proof. intros. induction n as [| n']. + - simpl. + assert (H0 : g 0 - g 0 = g 0 + g 0 - g 0). + { rewrite <- H. rewrite Cplus_0_r. easy. } + unfold Cminus in H0. + rewrite <- Cplus_assoc in H0. + rewrite Cplus_opp_r in H0. + rewrite Cplus_0_r in H0. + apply H0. + - do 2 (rewrite <- Csum_extend_r). + rewrite IHn'. + rewrite H. + reflexivity. +Qed. + + +Local Open Scope nat_scope. + +Lemma Csum_double_sum : forall (f : nat -> nat -> C) (n m : nat), + Csum (fun x => (Csum (fun y => f x y) n)) m = Csum (fun z => f (z / n) (z mod n)) (n * m). +Proof. induction m as [| m']. + - rewrite Nat.mul_0_r. + easy. + - rewrite Nat.mul_succ_r. + rewrite <- Csum_extend_r. + rewrite Csum_sum. + apply Csum_simplify; try easy. + apply Csum_eq_bounded; intros. + rewrite mult_comm. + rewrite Nat.div_add_l; try lia. + rewrite (plus_comm (m' * n)). + rewrite Nat.mod_add; try lia. + destruct (Nat.mod_small_iff x n) as [_ HD]; try lia. + destruct (Nat.div_small_iff x n) as [_ HA]; try lia. + rewrite HD, HA; try lia. + rewrite Nat.add_0_r. + easy. +Qed. + + +Lemma Csum_extend_double : forall (n m : nat) (f : nat -> nat -> C), + (Csum (fun i => Csum (fun j => f i j) (S m)) (S n)) = + ((Csum (fun i => Csum (fun j => f i j) m) n) + (Csum (fun j => f n j) m) + + (Csum (fun i => f i m) n) + f n m)%C. +Proof. intros. + rewrite <- Csum_extend_r. + assert (H' : forall a b c d, (a + b + c + d = (a + c) + (b + d))%C). + { intros. lca. } + rewrite H'. + apply Csum_simplify; try easy. + rewrite <- Csum_plus. + apply Csum_eq_bounded; intros. + easy. +Qed. + +Lemma Csum_rearrange : forall (n : nat) (f g : nat -> nat -> C), + (forall x y, x <= y -> f x y = -C1 * g (S y) x)%C -> + (forall x y, y <= x -> f (S x) y = -C1 * g y x)%C -> + Csum (fun i => Csum (fun j => f i j) n) (S n) = + (-C1 * (Csum (fun i => Csum (fun j => g i j) n) (S n)))%C. +Proof. induction n as [| n']. + - intros. lca. + - intros. + do 2 rewrite Csum_extend_double. + rewrite (IHn' f g); try easy. + repeat rewrite Cmult_plus_distr_l. + repeat rewrite <- Cplus_assoc. + apply Csum_simplify; try easy. + assert (H' : forall a b c, (a + (b + c) = (a + c) + b)%C). + intros. lca. + do 2 rewrite H'. + rewrite <- Cmult_plus_distr_l. + do 2 rewrite Csum_extend_r. + do 2 rewrite Csum_mult_l. + rewrite Cplus_comm. + apply Csum_simplify. + all : apply Csum_eq_bounded; intros. + apply H; lia. + apply H0; lia. +Qed. + +>>>>>>> Heisenberg-Foundations/main (**********************************) (** Proofs about Well-Formedness **) (**********************************) +<<<<<<< HEAD Local Open Scope nat_scope. +======= + +>>>>>>> Heisenberg-Foundations/main Lemma WF_Matrix_dim_change : forall (m n m' n' : nat) (A : Matrix m n), m = m' -> @@ -807,6 +1014,10 @@ Proof. lia. Qed. +<<<<<<< HEAD +======= + +>>>>>>> Heisenberg-Foundations/main Lemma Mmult_1_l: forall (m n : nat) (A : Matrix m n), WF_Matrix A -> I m × A = A. Proof. @@ -1134,6 +1345,22 @@ Proof. rewrite Cmult_assoc; reflexivity. Qed. +<<<<<<< HEAD +======= + +Lemma Mscale_div : forall {n m} (c : C) (A B : Matrix n m), + c <> C0 -> c .* A = c .* B -> A = B. +Proof. intros. + rewrite <- Mscale_1_l. rewrite <- (Mscale_1_l n m A). + rewrite <- (Cinv_l c). + rewrite <- Mscale_assoc. + rewrite H0. + lma. + apply H. +Qed. + + +>>>>>>> Heisenberg-Foundations/main Lemma Mscale_plus_distr_l : forall (m n : nat) (x y : C) (A : Matrix m n), (x + y) .* A = x .* A .+ y .* A. Proof. @@ -1202,13 +1429,18 @@ Proof. reflexivity. Qed. Lemma Mscale_adj : forall (m n : nat) (x : C) (A : Matrix m n), (x .* A)† = x^* .* A†. Proof. +<<<<<<< HEAD intros m n x A. +======= + intros m n xtranspose A. +>>>>>>> Heisenberg-Foundations/main unfold scale, adjoint. prep_matrix_equality. rewrite Cconj_mult_distr. reflexivity. Qed. +<<<<<<< HEAD (* Inverses of square matrices *) Definition Minv {n : nat} (A B : Square n) : Prop := A × B = I n /\ B × A = I n. @@ -1360,6 +1592,14 @@ Lemma Mplus_tranpose : forall (m n : nat) (A : Matrix m n) (B : Matrix m n), Proof. reflexivity. Qed. Lemma Mmult_tranpose : forall (m n o : nat) (A : Matrix m n) (B : Matrix n o), +======= + +Lemma Mplus_transpose : forall (m n : nat) (A : Matrix m n) (B : Matrix m n), + (A .+ B)⊤ = A⊤ .+ B⊤. +Proof. reflexivity. Qed. + +Lemma Mmult_transpose : forall (m n o : nat) (A : Matrix m n) (B : Matrix n o), +>>>>>>> Heisenberg-Foundations/main (A × B)⊤ = B⊤ × A⊤. Proof. intros m n o A B. @@ -1454,6 +1694,7 @@ Proof. rewrite H, H0; reflexivity. Qed. +<<<<<<< HEAD Lemma outer_product_eq : forall m (φ ψ : Matrix m 1), φ = ψ -> outer_product φ φ = outer_product ψ ψ. Proof. congruence. Qed. @@ -1517,187 +1758,3726 @@ Proof. rewrite Mmult_1_l. reflexivity. apply WF_I. replace (m1 * m1 ^ n) with (m1 ^ n * m1) by apply Nat.mul_comm. - replace (m2 * m2 ^ n) with (m2 ^ n * m2) by apply Nat.mul_comm. - replace (m3 * m3 ^ n) with (m3 ^ n * m3) by apply Nat.mul_comm. - rewrite kron_mixed_product. - rewrite IHn. - reflexivity. -Qed. +======= -Lemma kron_n_I : forall n, n ⨂ I 2 = I (2 ^ n). +(* this was origionally with the other Msum stuff, but I needed it earlier... *) +Lemma Msum_Csum : forall {d1 d2} n (f : nat -> Matrix d1 d2) i j, + Msum n f i j = Csum (fun x => f x i j) n. Proof. - intros. + intros. induction n; simpl. reflexivity. - rewrite IHn. - rewrite id_kron. - apply f_equal. - lia. + unfold Mplus. + rewrite IHn. + reflexivity. Qed. -Lemma Mmult_n_kron_distr_l : forall {m n} i (A : Square m) (B : Square n), - i ⨉ (A ⊗ B) = (i ⨉ A) ⊗ (i ⨉ B). -Proof. - intros m n i A B. - induction i; simpl. - rewrite id_kron; reflexivity. - rewrite IHi. - rewrite kron_mixed_product. - reflexivity. + + +(*****************************************************) +(* Defining matrix altering/col operations functions *) +(*****************************************************) + +Local Open Scope nat_scope. + +Definition get_vec {n m} (i : nat) (S : Matrix n m) : Vector n := + fun x y => (if (y =? 0) then S x i else C0). + + +Definition get_row {n m} (i : nat) (S : Matrix n m) : Matrix 1 m := + fun x y => (if (x =? 0) then S i y else C0). + + +Definition reduce_row {n m} (A : Matrix n m) (row : nat) : Matrix (n - 1) m := + fun x y => if x if y if x (if x if (j =? m) then v i 0 else T i j. + + +Definition row_append {n m} (T : Matrix n m) (v : Matrix 1 m) : Matrix (S n) m := + fun i j => if (i =? n) then v 0 j else T i j. + +(* more general than col_append *) +Definition smash {n m1 m2} (T1 : Matrix n m1) (T2 : Matrix n m2) : Matrix n (m1 + m2) := + fun i j => if j if j if i if (j =? x) + then S i y + else if (j =? y) + then S i x + else S i j. + +Definition row_swap {n m : nat} (S : Matrix n m) (x y : nat) : Matrix n m := + fun i j => if (i =? x) + then S y j + else if (i =? y) + then S x j + else S i j. + +Definition col_scale {n m : nat} (S : Matrix n m) (col : nat) (a : C) : Matrix n m := + fun i j => if (j =? col) + then (a * S i j)%C + else S i j. + +Definition row_scale {n m : nat} (S : Matrix n m) (row : nat) (a : C) : Matrix n m := + fun i j => if (i =? row) + then (a * S i j)%C + else S i j. + +(* adding one column to another *) +Definition col_add {n m : nat} (S : Matrix n m) (col to_add : nat) (a : C) : Matrix n m := + fun i j => if (j =? col) + then (S i j + a * S i to_add)%C + else S i j. + +(* adding one row to another *) +Definition row_add {n m : nat} (S : Matrix n m) (row to_add : nat) (a : C) : Matrix n m := + fun i j => if (i =? row) + then (S i j + a * S to_add j)%C + else S i j. + + +(* generalizing col_add *) +Definition gen_new_vec (n m : nat) (S : Matrix n m) (as' : Vector m) : Vector n := + Msum m (fun i => (as' i 0) .* (get_vec i S)). + +Definition gen_new_row (n m : nat) (S : Matrix n m) (as' : Matrix 1 n) : Matrix 1 m := + Msum n (fun i => (as' 0 i) .* (get_row i S)). + +(* adds all columns to single column *) +Definition col_add_many {n m} (col : nat) (as' : Vector m) (S : Matrix n m) : Matrix n m := + fun i j => if (j =? col) + then (S i j + (gen_new_vec n m S as') i 0)%C + else S i j. + +Definition row_add_many {n m} (row : nat) (as' : Matrix 1 n) (S : Matrix n m) : Matrix n m := + fun i j => if (i =? row) + then (S i j + (gen_new_row n m S as') 0 j)%C + else S i j. + +(* adds single column to each other column *) +Definition col_add_each {n m} (col : nat) (as' : Matrix 1 m) (S : Matrix n m) : Matrix n m := + S .+ ((get_vec col S) × as'). + + +Definition row_add_each {n m} (row : nat) (as' : Vector n) (S : Matrix n m) : Matrix n m := + S .+ (as' × get_row row S). + + +Definition make_col_zero {n m} (col : nat) (S : Matrix n m) : Matrix n m := + fun i j => if (j =? col) + then C0 + else S i j. + +Definition make_row_zero {n m} (row : nat) (S : Matrix n m) : Matrix n m := + fun i j => if (i =? row) + then C0 + else S i j. + +Definition make_WF {n m} (S : Matrix n m) : Matrix n m := + fun i j => if (i WF_Matrix (get_vec i S). +Proof. unfold WF_Matrix, get_vec in *. + intros. + bdestruct (y =? 0); try lia; try easy. + apply H. + destruct H0. + left; easy. + lia. Qed. -Lemma Mmult_n_1_l : forall {n} (A : Square n), - WF_Matrix A -> - 1 ⨉ A = A. -Proof. intros n A WF. simpl. rewrite Mmult_1_r; auto. Qed. +Lemma WF_get_row : forall {n m} (i : nat) (S : Matrix n m), + WF_Matrix S -> WF_Matrix (get_row i S). +Proof. unfold WF_Matrix, get_row in *. + intros. + bdestruct (x =? 0); try lia; try easy. + apply H. + destruct H0. + lia. + right; easy. +Qed. -Lemma Mmult_n_1_r : forall n i, - i ⨉ (I n) = I n. -Proof. - intros n i. - induction i; simpl. - reflexivity. - rewrite IHi. - rewrite Mmult_1_l; auto with wf_db. + +Lemma WF_reduce_row : forall {n m} (row : nat) (A : Matrix n m), + row < n -> WF_Matrix A -> WF_Matrix (reduce_row A row). +Proof. unfold WF_Matrix, reduce_row. intros. + bdestruct (x b < c -> 1 + a < c). + { lia. } + apply (nibzo x row n) in H2. + simpl in H2. lia. apply H. + + apply H0; auto. + - apply H0. destruct H1. + + left. simpl. lia. + + right. apply H1. Qed. -Lemma Mmult_n_eigenvector : forall {n} (A : Square n) (ψ : Vector n) λ i, - WF_Matrix ψ -> A × ψ = λ .* ψ -> - i ⨉ A × ψ = (λ ^ i) .* ψ. -Proof. - intros n A ψ λ i WF H. - induction i; simpl. - rewrite Mmult_1_l; auto. - rewrite Mscale_1_l; auto. - rewrite Mmult_assoc. - rewrite IHi. - rewrite Mscale_mult_dist_r. - rewrite H. - rewrite Mscale_assoc. - rewrite Cmult_comm. - reflexivity. + +Lemma WF_reduce_col : forall {n m} (col : nat) (A : Matrix n m), + col < m -> WF_Matrix A -> WF_Matrix (reduce_col A col). +Proof. unfold WF_Matrix, reduce_col. intros. + bdestruct (y b < c -> 1 + a < c). + { lia. } + apply (nibzo y col m) in H2. + simpl in H2. lia. apply H. + - apply H0. destruct H1. + + left. apply H1. + + right. simpl. lia. Qed. -Lemma Msum_eq_bounded : forall {d1 d2} n (f f' : nat -> Matrix d1 d2), - (forall i, (i < n)%nat -> f i = f' i) -> Msum n f = Msum n f'. -Proof. - intros d1 d2 n f f' Heq. - induction n; simpl. - reflexivity. - rewrite Heq by lia. - rewrite IHn. reflexivity. - intros. apply Heq. lia. + +Lemma rvn_is_rr_n : forall {n : nat} (v : Vector n), + reduce_vecn v = reduce_row v (n - 1). +Proof. intros. + prep_matrix_equality. + unfold reduce_row, reduce_vecn. + easy. Qed. -Lemma kron_Msum_distr_l : - forall {d1 d2 d3 d4} n (f : nat -> Matrix d1 d2) (A : Matrix d3 d4), - A ⊗ Msum n f = Msum n (fun i => A ⊗ f i). -Proof. - intros. - induction n; simpl. lma. - rewrite kron_plus_distr_l, IHn. reflexivity. +Lemma WF_reduce_vecn : forall {n} (v : Vector n), + n <> 0 -> WF_Matrix v -> WF_Matrix (reduce_vecn v). +Proof. intros. + rewrite rvn_is_rr_n. + apply WF_reduce_row; try lia; try easy. Qed. -Lemma kron_Msum_distr_r : - forall {d1 d2 d3 d4} n (f : nat -> Matrix d1 d2) (A : Matrix d3 d4), - Msum n f ⊗ A = Msum n (fun i => f i ⊗ A). -Proof. - intros. - induction n; simpl. lma. - rewrite kron_plus_distr_r, IHn. reflexivity. + +Lemma reduce_is_redrow_redcol : forall {n} (A : Square n) (row col : nat), + reduce A row col = reduce_col (reduce_row A row) col. +Proof. intros. + prep_matrix_equality. + unfold reduce, reduce_col, reduce_row. + bdestruct (x 0 -> row < n -> col < n -> WF_Matrix A -> WF_Matrix (reduce A row col). +Proof. intros. + rewrite reduce_is_redrow_redcol. + apply WF_reduce_col; try easy. + apply WF_reduce_row; try easy. Qed. -Lemma Mmult_Msum_distr_l : forall {d1 d2 m} n (f : nat -> Matrix d1 d2) (A : Matrix m d1), - A × Msum n f = Msum n (fun i => A × f i). -Proof. - intros. - induction n; simpl. - rewrite Mmult_0_r. reflexivity. - rewrite Mmult_plus_distr_l, IHn. reflexivity. +Lemma WF_col_swap : forall {n m : nat} (S : Matrix n m) (x y : nat), + x < m -> y < m -> WF_Matrix S -> WF_Matrix (col_swap S x y). +Proof. unfold WF_Matrix, col_swap in *. + intros. + bdestruct (y0 =? x); bdestruct (y0 =? y); destruct H2; try lia. + all : apply H1; try (left; apply H2). + auto. Qed. -Lemma Mmult_Msum_distr_r : forall {d1 d2 m} n (f : nat -> Matrix d1 d2) (A : Matrix d2 m), - Msum n f × A = Msum n (fun i => f i × A). -Proof. - intros. - induction n; simpl. - rewrite Mmult_0_l. reflexivity. - rewrite Mmult_plus_distr_r, IHn. reflexivity. +Lemma WF_row_swap : forall {n m : nat} (S : Matrix n m) (x y : nat), + x < n -> y < n -> WF_Matrix S -> WF_Matrix (row_swap S x y). +Proof. unfold WF_Matrix, row_swap in *. + intros. + bdestruct (x0 =? x); bdestruct (x0 =? y); destruct H2; try lia. + all : apply H1; try (right; apply H2). + auto. Qed. -Lemma Mscale_Msum_distr_r : forall {d1 d2} x n (f : nat -> Matrix d1 d2), - x .* Msum n f = Msum n (fun i => x .* f i). -Proof. - intros d1 d2 x n f. - induction n; simpl. lma. - rewrite Mscale_plus_distr_r, IHn. reflexivity. +Lemma WF_col_scale : forall {n m : nat} (S : Matrix n m) (x : nat) (a : C), + WF_Matrix S -> WF_Matrix (col_scale S x a). +Proof. unfold WF_Matrix, col_scale in *. + intros. + apply H in H0. + rewrite H0. + rewrite Cmult_0_r. + bdestruct (y =? x); easy. Qed. -Lemma Mscale_Msum_distr_l : forall {d1 d2} n (f : nat -> C) (A : Matrix d1 d2), - Msum n (fun i => (f i) .* A) = Csum f n .* A. -Proof. - intros d1 d2 n f A. - induction n; simpl. lma. - rewrite Mscale_plus_distr_l, IHn. reflexivity. +Lemma WF_row_scale : forall {n m : nat} (S : Matrix n m) (x : nat) (a : C), + WF_Matrix S -> WF_Matrix (row_scale S x a). +Proof. unfold WF_Matrix, row_scale in *. + intros. + apply H in H0. + rewrite H0. + rewrite Cmult_0_r. + bdestruct (x0 =? x); easy. Qed. -Lemma Msum_0 : forall {d1 d2} n (f : nat -> Matrix d1 d2), - (forall x, x < n -> f x = Zero) -> Msum n f = Zero. -Proof. - intros d1 d2 n f Hf. - induction n; simpl. reflexivity. - rewrite IHn, Hf. lma. - lia. intros. apply Hf. lia. + +Lemma WF_col_add : forall {n m : nat} (S : Matrix n m) (x y : nat) (a : C), + x < m -> WF_Matrix S -> WF_Matrix (col_add S x y a). +Proof. unfold WF_Matrix, col_add in *. + intros. + bdestruct (y0 =? x); destruct H1; try lia. + do 2 (rewrite H0; auto). lca. + all : apply H0; auto. Qed. -Lemma Msum_constant : forall {d1 d2} n (A : Matrix d1 d2), Msum n (fun _ => A) = INR n .* A. -Proof. - intros. - induction n. - simpl. lma. - simpl Msum. - rewrite IHn. - replace (S n) with (n + 1)%nat by lia. - rewrite plus_INR; simpl. - rewrite RtoC_plus. - rewrite Mscale_plus_distr_l. - lma. + +Lemma WF_row_add : forall {n m : nat} (S : Matrix n m) (x y : nat) (a : C), + x < n -> WF_Matrix S -> WF_Matrix (row_add S x y a). +Proof. unfold WF_Matrix, row_add in *. + intros. + bdestruct (x0 =? x); destruct H1; try lia. + do 2 (rewrite H0; auto). lca. + all : apply H0; auto. Qed. -Lemma Msum_plus : forall {d1 d2} n (f1 f2 : nat -> Matrix d1 d2), - Msum n (fun i => (f1 i) .+ (f2 i)) = Msum n f1 .+ Msum n f2. -Proof. - intros d1 d2 n f1 f2. - induction n; simpl. lma. - rewrite IHn. lma. + +Lemma WF_gen_new_vec : forall {n m} (S : Matrix n m) (as' : Vector m), + WF_Matrix S -> WF_Matrix (gen_new_vec n m S as'). +Proof. intros. + unfold gen_new_vec. + apply WF_Msum; intros. + apply WF_scale. + apply WF_get_vec. + easy. Qed. -Lemma Msum_adjoint : forall {d1 d2} n (f : nat -> Matrix d1 d2), - (Msum n f)† = Msum n (fun i => (f i)†). -Proof. - intros. - induction n; simpl. - lma. - rewrite Mplus_adjoint, IHn. - reflexivity. + +Lemma WF_gen_new_row : forall {n m} (S : Matrix n m) (as' : Matrix 1 n), + WF_Matrix S -> WF_Matrix (gen_new_row n m S as'). +Proof. intros. + unfold gen_new_row. + apply WF_Msum; intros. + apply WF_scale. + apply WF_get_row. + easy. Qed. -Lemma Msum_Csum : forall {d1 d2} n (f : nat -> Matrix d1 d2) i j, - Msum n f i j = Csum (fun x => f x i j) n. -Proof. - intros. - induction n; simpl. - reflexivity. - unfold Mplus. - rewrite IHn. - reflexivity. +Lemma WF_col_add_many : forall {n m} (col : nat) (as' : Vector m) (S : Matrix n m), + col < m -> WF_Matrix S -> WF_Matrix (col_add_many col as' S). +Proof. unfold WF_Matrix, col_add_many. + intros. + bdestruct (y =? col). + assert (H4 := (WF_gen_new_vec S as')). + rewrite H4, H0; try easy. + lca. destruct H2; lia. + rewrite H0; easy. Qed. -Lemma Msum_unique : forall {d1 d2} n (f : nat -> Matrix d1 d2) (A : Matrix d1 d2), - (exists i, i < n /\ f i = A /\ (forall j, j < n -> j <> i -> f j = Zero)) -> - Msum n f = A. -Proof. - intros d1 d2 n f A H. +Lemma WF_row_add_many : forall {n m} (row : nat) (as' : Matrix 1 n) (S : Matrix n m), + row < n -> WF_Matrix S -> WF_Matrix (row_add_many row as' S). +Proof. unfold WF_Matrix, row_add_many. + intros. + bdestruct (x =? row). + assert (H4 := (WF_gen_new_row S as')). + rewrite H4, H0; try easy. + lca. destruct H2; lia. + rewrite H0; easy. +Qed. + + +Lemma WF_col_append : forall {n m} (T : Matrix n m) (v : Vector n), + WF_Matrix T -> WF_Matrix v -> WF_Matrix (col_append T v). +Proof. unfold WF_Matrix in *. + intros; destruct H1 as [H1 | H1]. + - unfold col_append. + rewrite H, H0; try lia. + bdestruct (y =? m); easy. + - unfold col_append. + bdestruct (y =? m); try lia. + apply H; lia. +Qed. + + +Lemma WF_row_append : forall {n m} (T : Matrix n m) (v : Matrix 1 m), + WF_Matrix T -> WF_Matrix v -> WF_Matrix (row_append T v). +Proof. unfold WF_Matrix in *. + intros; destruct H1 as [H1 | H1]. + - unfold row_append. + bdestruct (x =? n); try lia. + apply H; lia. + - unfold row_append. + rewrite H, H0; try lia. + bdestruct (x =? n); easy. +Qed. + + +Lemma WF_col_wedge : forall {n m} (T : Matrix n m) (v : Vector n) (spot : nat), + spot <= m -> WF_Matrix T -> WF_Matrix v -> WF_Matrix (col_wedge T v spot). +Proof. unfold WF_Matrix in *. + intros; destruct H2 as [H2 | H2]. + - unfold col_wedge. + rewrite H0, H1; try lia. + rewrite H0; try lia. + bdestruct (y WF_Matrix T -> WF_Matrix v -> WF_Matrix (row_wedge T v spot). +Proof. unfold WF_Matrix in *. + intros; destruct H2 as [H2 | H2]. + - unfold row_wedge. + bdestruct (x WF_Matrix T2 -> WF_Matrix (smash T1 T2). +Proof. unfold WF_Matrix, smash in *. + intros. + bdestruct (y WF_Matrix as' -> WF_Matrix (col_add_each col as' S). +Proof. intros. + unfold col_add_each. + apply WF_plus; try easy; + apply WF_mult; try easy; + apply WF_get_vec; easy. +Qed. + +Lemma WF_row_add_each : forall {n m} (row : nat) (as' : Vector n) (S : Matrix n m), + WF_Matrix S -> WF_Matrix as' -> WF_Matrix (row_add_each row as' S). +Proof. intros. + unfold row_add_each. + apply WF_plus; try easy; + apply WF_mult; try easy; + apply WF_get_row; easy. +Qed. + +Lemma WF_make_col_zero : forall {n m} (col : nat) (S : Matrix n m), + WF_Matrix S -> WF_Matrix (make_col_zero col S). +Proof. unfold make_col_zero, WF_Matrix. + intros. + rewrite H; try easy. + bdestruct (y =? col); easy. +Qed. + +Lemma WF_make_row_zero : forall {n m} (row : nat) (S : Matrix n m), + WF_Matrix S -> WF_Matrix (make_row_zero row S). +Proof. unfold make_row_zero, WF_Matrix. + intros. + rewrite H; try easy. + bdestruct (x =? row); easy. +Qed. + +Lemma WF_make_WF : forall {n m} (S : Matrix n m), WF_Matrix (make_WF S). +Proof. intros. + unfold WF_Matrix, make_WF; intros. + destruct H as [H | H]. + bdestruct (x get_vec i (reduce_col A col) = get_vec i A. +Proof. intros. + prep_matrix_equality. + unfold get_vec, reduce_col. + bdestruct (i A = B. +Proof. intros. prep_matrix_equality. + rewrite <- get_vec_conv. + rewrite <- (get_vec_conv _ _ B). + rewrite H. + reflexivity. +Qed. + + +Lemma col_scale_reduce_col_same : forall {n m} (T : Matrix n m) (y col : nat) (a : C), + y = col -> reduce_col (col_scale T col a) y = reduce_col T y. +Proof. intros. + prep_matrix_equality. + unfold reduce_col, col_scale. + bdestruct (y0 col < (S c2) -> + reduce (col_swap T (S c1) (S c2)) row col = col_swap (reduce T row col) c1 c2. +Proof. intros. + prep_matrix_equality. + unfold reduce, col_swap. + bdestruct (c1 reduce (col_scale T col a) x y = col_scale (reduce T x y) (col - 1) a. +Proof. intros. + prep_matrix_equality. + destruct col; try lia. + rewrite easy_sub. + unfold reduce, col_scale. + bdestruct (x0 reduce (col_scale T col a) x y = reduce T x y. +Proof. intros. + prep_matrix_equality. + unfold reduce, col_scale. + bdestruct (x0 col -> reduce (col_scale T col a) x y = col_scale (reduce T x y) col a. +Proof. intros. + prep_matrix_equality. + unfold reduce, col_scale. + bdestruct (x0 z -> y <> z -> col_swap T x z = col_swap (col_swap (col_swap T x y) y z) x y. +Proof. intros. + bdestruct (x =? y). + rewrite H1, col_swap_same, col_swap_same. + easy. + prep_matrix_equality. + unfold col_swap. + bdestruct (y =? y); bdestruct (y =? x); bdestruct (y =? z); try lia. + bdestruct (x =? y); bdestruct (x =? x); bdestruct (x =? z); try lia. + bdestruct (z =? y); bdestruct (z =? x); try lia. + bdestruct (y0 =? y); bdestruct (y0 =? x); bdestruct (y0 =? z); + try lia; try easy. + rewrite H10. + easy. +Qed. + +Lemma reduce_row_reduce_col : forall {n m} (A : Matrix n m) (i j : nat), + reduce_col (reduce_row A i) j = reduce_row (reduce_col A j) i. +Proof. intros. + prep_matrix_equality. + unfold reduce_col, reduce_row. + bdestruct (y + (reduce (reduce A x 0) y 0) = (reduce (reduce A (S y) 0) x 0). +Proof. intros. + prep_matrix_equality. + unfold reduce. + bdestruct (y0 0 -> i <> j -> col_swap (col_add (col_swap A j 0) 0 i c) j 0 = col_add A j i c. +Proof. intros. + bdestruct (j =? 0). + - rewrite H1. + do 2 rewrite col_swap_same; easy. + - prep_matrix_equality. + unfold col_swap, col_add. + bdestruct (y =? j); bdestruct (j =? j); try lia; simpl. + destruct j; try lia. + bdestruct (i =? S j); bdestruct (i =? 0); try lia. + rewrite H2; easy. + bdestruct (y =? 0); bdestruct (j =? 0); try easy. + rewrite H4; easy. +Qed. + +Lemma col_swap_col_add_0 : forall {n} (A : Square n) (j : nat) (c : C), + j <> 0 -> col_swap (col_add (col_swap A j 0) 0 j c) j 0 = col_add A j 0 c. +Proof. intros. + prep_matrix_equality. + unfold col_swap, col_add. + bdestruct (y =? j); bdestruct (j =? j); bdestruct (0 =? j); try lia; simpl. + rewrite H0; easy. + bdestruct (y =? 0); bdestruct (j =? 0); try easy. + rewrite H3; easy. +Qed. + +Lemma col_swap_end_reduce_col_hit : forall {n m : nat} (T : Matrix n (S (S m))) (i : nat), + i <= m -> col_swap (reduce_col T i) m i = reduce_col (col_swap T (S m) (S i)) i. +Proof. intros. + prep_matrix_equality. + unfold reduce_col, col_swap. + bdestruct (i C0 -> S = col_scale (col_scale S x a) x (/ a). +Proof. intros. + prep_matrix_equality. + unfold col_scale. + bdestruct (y =? x); try easy. + rewrite Cmult_assoc. + rewrite Cinv_l; try lca; easy. +Qed. + + +Lemma row_scale_inv : forall {n m : nat} (S : Matrix n m) (x : nat) (a : C), + a <> C0 -> S = row_scale (row_scale S x a) x (/ a). +Proof. intros. + prep_matrix_equality. + unfold row_scale. + bdestruct (x0 =? x); try easy. + rewrite Cmult_assoc. + rewrite Cinv_l; try lca; easy. +Qed. + + + +Lemma col_add_double : forall {n m : nat} (S : Matrix n m) (x : nat) (a : C), + col_add S x x a = col_scale S x (C1 + a). +Proof. intros. + prep_matrix_equality. + unfold col_add, col_scale. + bdestruct (y =? x). + - rewrite H; lca. + - easy. +Qed. + +Lemma row_add_double : forall {n m : nat} (S : Matrix n m) (x : nat) (a : C), + row_add S x x a = row_scale S x (C1 + a). +Proof. intros. + prep_matrix_equality. + unfold row_add, row_scale. + bdestruct (x0 =? x). + - rewrite H; lca. + - easy. +Qed. + +Lemma col_add_swap : forall {n m : nat} (S : Matrix n m) (x y : nat) (a : C), + col_swap (col_add S x y a) x y = col_add (col_swap S x y) y x a. +Proof. intros. + prep_matrix_equality. + unfold col_swap, col_add. + bdestruct (y0 =? x); bdestruct (y =? x); + bdestruct (y0 =? y); bdestruct (x =? x); try lia; easy. +Qed. + +Lemma row_add_swap : forall {n m : nat} (S : Matrix n m) (x y : nat) (a : C), + row_swap (row_add S x y a) x y = row_add (row_swap S x y) y x a. +Proof. intros. + prep_matrix_equality. + unfold row_swap, row_add. + bdestruct (x0 =? x); bdestruct (y =? x); + bdestruct (x0 =? y); bdestruct (x =? x); try lia; easy. +Qed. + + +Lemma col_add_inv : forall {n m : nat} (S : Matrix n m) (x y : nat) (a : C), + x <> y -> S = col_add (col_add S x y a) x y (-a). +Proof. intros. + prep_matrix_equality. + unfold col_add. + bdestruct (y0 =? x); bdestruct (y =? x); try lia. + lca. easy. +Qed. + +Lemma row_add_inv : forall {n m : nat} (S : Matrix n m) (x y : nat) (a : C), + x <> y -> S = row_add (row_add S x y a) x y (-a). +Proof. intros. + prep_matrix_equality. + unfold row_add. + bdestruct (x0 =? x); bdestruct (y =? x); try lia. + lca. easy. +Qed. + + + +Lemma mat_equiv_make_WF : forall {n m} (T : Matrix n m), + T == make_WF T. +Proof. unfold make_WF, mat_equiv; intros. + bdestruct (i gen_new_vec n m T as' = Zero. +Proof. intros. + unfold mat_equiv, gen_new_vec in *. + prep_matrix_equality. + rewrite Msum_Csum. + unfold Zero in *. + apply Csum_0_bounded; intros. + rewrite H; try lia. + rewrite Mscale_0_l. + easy. +Qed. + +Lemma gen_new_row_0 : forall {n m} (T : Matrix n m) (as' : Matrix 1 n), + as' == Zero -> gen_new_row n m T as' = Zero. +Proof. intros. + unfold mat_equiv, gen_new_row in *. + prep_matrix_equality. + rewrite Msum_Csum. + unfold Zero in *. + apply Csum_0_bounded; intros. + rewrite H; try lia. + rewrite Mscale_0_l. + easy. +Qed. + +Lemma col_add_many_0 : forall {n m} (col : nat) (T : Matrix n m) (as' : Vector m), + as' == Zero -> T = col_add_many col as' T. +Proof. intros. + unfold col_add_many in *. + prep_matrix_equality. + bdestruct (y =? col); try easy. + rewrite gen_new_vec_0; try easy. + unfold Zero; lca. +Qed. + +Lemma row_add_many_0 : forall {n m} (row : nat) (T : Matrix n m) (as' : Matrix 1 n), + as' == Zero -> T = row_add_many row as' T. +Proof. intros. + unfold row_add_many in *. + prep_matrix_equality. + bdestruct (x =? row); try easy. + rewrite gen_new_row_0; try easy. + unfold Zero; lca. +Qed. + + +Lemma gen_new_vec_mat_equiv : forall {n m} (T : Matrix n m) (as' bs : Vector m), + as' == bs -> gen_new_vec n m T as' = gen_new_vec n m T bs. +Proof. unfold mat_equiv, gen_new_vec; intros. + prep_matrix_equality. + do 2 rewrite Msum_Csum. + apply Csum_eq_bounded; intros. + rewrite H; try lia. + easy. +Qed. + +Lemma gen_new_row_mat_equiv : forall {n m} (T : Matrix n m) (as' bs : Matrix 1 n), + as' == bs -> gen_new_row n m T as' = gen_new_row n m T bs. +Proof. unfold mat_equiv, gen_new_row; intros. + prep_matrix_equality. + do 2 rewrite Msum_Csum. + apply Csum_eq_bounded; intros. + rewrite H; try lia. + easy. +Qed. + +Lemma col_add_many_mat_equiv : forall {n m} (col : nat) (T : Matrix n m) (as' bs : Vector m), + as' == bs -> col_add_many col as' T = col_add_many col bs T. +Proof. intros. + unfold col_add_many. + rewrite (gen_new_vec_mat_equiv _ as' bs); easy. +Qed. + +Lemma row_add_many_mat_equiv : forall {n m} (row : nat) (T : Matrix n m) (as' bs : Matrix 1 n), + as' == bs -> row_add_many row as' T = row_add_many row bs T. +Proof. intros. + unfold row_add_many. + rewrite (gen_new_row_mat_equiv _ as' bs); easy. +Qed. + + +Lemma col_add_each_0 : forall {n m} (col : nat) (T : Matrix n m) (v : Matrix 1 m), + v = Zero -> T = col_add_each col v T. +Proof. intros. + rewrite H. + unfold col_add_each. + rewrite Mmult_0_r. + rewrite Mplus_0_r. + easy. +Qed. + +Lemma row_add_each_0 : forall {n m} (row : nat) (T : Matrix n m) (v : Vector n), + v = Zero -> T = row_add_each row v T. +Proof. intros. + rewrite H. + unfold row_add_each. + rewrite Mmult_0_l. + rewrite Mplus_0_r. + easy. +Qed. + + + +Lemma col_add_many_col_add : forall {n m} (col e : nat) (T : Matrix n m) (as' : Vector m), + col <> e -> e < m -> as' col 0 = C0 -> + col_add_many col as' T = + col_add (col_add_many col (make_row_zero e as') T) col e (as' e 0). +Proof. intros. + unfold col_add_many, col_add, gen_new_vec. + prep_matrix_equality. + bdestruct (y =? col); try easy. + bdestruct (e =? col); try lia. + rewrite <- Cplus_assoc. + apply Csum_simplify; try easy. + assert (H' : m = e + (m - e)). lia. + rewrite H'. + do 2 rewrite Msum_Csum. + rewrite Csum_sum. + rewrite Csum_sum. + rewrite <- Cplus_assoc. + apply Csum_simplify. + apply Csum_eq_bounded; intros. + unfold make_row_zero. + bdestruct (x0 =? e); try lia; easy. + destruct (m - e); try lia. + do 2 rewrite <- Csum_extend_l. + unfold make_row_zero. + bdestruct (e + 0 =? e); try lia. + unfold scale. + rewrite Cmult_0_l, Cplus_0_l. + rewrite Cplus_comm. + apply Csum_simplify. + apply Csum_eq_bounded; intros. + bdestruct (e + S x0 =? e); try lia; easy. + unfold get_vec. simpl. + rewrite plus_0_r; easy. +Qed. + + +Lemma col_add_many_cancel : forall {n m} (T : Matrix n m) (as' : Vector m) (col : nat), + col < m -> as' col 0 = C0 -> + (reduce_col T col) × (reduce_row as' col) = -C1 .* (get_vec col T) -> + (forall i : nat, (col_add_many col as' T) i col = C0). +Proof. intros. + destruct m; try lia. + unfold col_add_many, gen_new_vec. + bdestruct (col =? col); try lia. + rewrite Msum_Csum. + assert (H' : (Csum (fun x : nat => (as' x 0 .* get_vec x T) i 0) (S m) = + (@Mmult n m 1 (reduce_col T col) (reduce_row as' col)) i 0)%C). + { unfold Mmult. + assert (p : S m = col + (S (m - col))). lia. + assert (p1 : m = col + (m - col)). lia. + rewrite p; rewrite Csum_sum. + rewrite p1; rewrite Csum_sum. + apply Csum_simplify. + apply Csum_eq_bounded; intros. + unfold get_vec, scale, reduce_col, reduce_row. + bdestruct (x S = col_add_many col (-C1 .* as') (col_add_many col as' S). +Proof. intros. + unfold col_add_many, gen_new_vec. + prep_matrix_equality. + bdestruct (y =? col); try easy. + rewrite <- (Cplus_0_r (S x y)). + rewrite <- Cplus_assoc. + apply Csum_simplify; try lca. + do 2 rewrite Msum_Csum. + rewrite <- Csum_plus. + rewrite Csum_0_bounded; try lca. + intros. + unfold get_vec, scale. + bdestruct (0 =? 0); bdestruct (x0 =? col); try lia; try lca. + rewrite Msum_Csum. + bdestruct (0 =? 0); try lia. + rewrite H3, H. lca. +Qed. + + +Lemma col_add_each_col_add : forall {n m} (col e : nat) (S : Matrix n m) (as' : Matrix 1 m), + col <> e -> (forall x, as' x col = C0) -> + col_add_each col as' S = + col_add (col_add_each col (make_col_zero e as') S) e col (as' 0 e). +Proof. intros. + prep_matrix_equality. + unfold col_add_each, col_add, make_col_zero, Mmult, Mplus, get_vec, Csum. + bdestruct (y =? col); bdestruct (y =? e); bdestruct (col =? e); + bdestruct (e =? e); bdestruct (0 =? 0); try lia; try lca. + rewrite H0. + rewrite H2. lca. +Qed. + + +Lemma row_add_each_row_add : forall {n m} (row e : nat) (S : Matrix n m) (as' : Vector n), + row <> e -> (forall y, as' row y = C0) -> + row_add_each row as' S = + row_add (row_add_each row (make_row_zero e as') S) e row (as' e 0). +Proof. intros. + prep_matrix_equality. + unfold row_add_each, row_add, make_row_zero, Mmult, Mplus, get_row, Csum. + bdestruct (x =? row); bdestruct (x =? e); bdestruct (row =? e); + bdestruct (e =? e); bdestruct (0 =? 0); try lia; try lca. + rewrite H0. + rewrite H2. lca. +Qed. + + +(* must use make_col_zero here instead of just as' col 0 = C0, since def requires stronger supp *) +Lemma col_add_each_inv : forall {n m} (col : nat) (as' : Matrix 1 m) (T : Matrix n m), + T = col_add_each col (make_col_zero col (-C1 .* as')) + (col_add_each col (make_col_zero col as') T). +Proof. intros. + prep_matrix_equality. + unfold col_add_each, make_col_zero, Mmult, Mplus, get_vec, scale. + simpl. bdestruct (y =? col); bdestruct (col =? col); try lia; try lca. +Qed. + +Lemma row_add_each_inv : forall {n m} (row : nat) (as' : Vector n) (T : Matrix n m), + T = row_add_each row (make_row_zero row (-C1 .* as')) + (row_add_each row (make_row_zero row as') T). +Proof. intros. + prep_matrix_equality. + unfold row_add_each, make_row_zero, Mmult, Mplus, get_row, scale. + simpl. bdestruct (x =? row); bdestruct (row =? row); try lia; try lca. +Qed. + + +(* we can show that we get from col_XXX to row_XXX via transposing *) + +Lemma get_vec_transpose : forall {n m} (A : Matrix n m) (i : nat), + (get_vec i A)⊤ = get_row i (A⊤). +Proof. intros. + prep_matrix_equality. + unfold get_vec, get_row, transpose. + easy. +Qed. + +Lemma get_row_transpose : forall {n m} (A : Matrix n m) (i : nat), + (get_row i A)⊤ = get_vec i (A⊤). +Proof. intros. + prep_matrix_equality. + unfold get_vec, get_row, transpose. + easy. +Qed. + +Lemma col_swap_transpose : forall {n m} (A : Matrix n m) (x y : nat), + (col_swap A x y)⊤ = row_swap (A⊤) x y. +Proof. intros. + prep_matrix_equality. + unfold row_swap, col_swap, transpose. + easy. +Qed. + +Lemma row_swap_transpose : forall {n m} (A : Matrix n m) (x y : nat), + (row_swap A x y)⊤ = col_swap (A⊤) x y. +Proof. intros. + prep_matrix_equality. + unfold row_swap, col_swap, transpose. + easy. +Qed. + +Lemma col_scale_transpose : forall {n m} (A : Matrix n m) (x : nat) (a : C), + (col_scale A x a)⊤ = row_scale (A⊤) x a. +Proof. intros. + prep_matrix_equality. + unfold row_scale, col_scale, transpose. + easy. +Qed. + +Lemma row_scale_transpose : forall {n m} (A : Matrix n m) (x : nat) (a : C), + (row_scale A x a)⊤ = col_scale (A⊤) x a. +Proof. intros. + prep_matrix_equality. + unfold row_scale, col_scale, transpose. + easy. +Qed. + +Lemma col_add_transpose : forall {n m} (A : Matrix n m) (col to_add : nat) (a : C), + (col_add A col to_add a)⊤ = row_add (A⊤) col to_add a. +Proof. intros. + prep_matrix_equality. + unfold row_add, col_add, transpose. + easy. +Qed. + +Lemma row_add_transpose : forall {n m} (A : Matrix n m) (row to_add : nat) (a : C), + (row_add A row to_add a)⊤ = col_add (A⊤) row to_add a. +Proof. intros. + prep_matrix_equality. + unfold row_add, col_add, transpose. + easy. +Qed. + +Lemma col_add_many_transpose : forall {n m} (A : Matrix n m) (col : nat) (as' : Vector m), + (col_add_many col as' A)⊤ = row_add_many col (as'⊤) (A⊤). +Proof. intros. + prep_matrix_equality. + unfold row_add_many, col_add_many, transpose. + bdestruct (x =? col); try easy. + apply Csum_simplify; try easy. + unfold gen_new_vec, gen_new_row, get_vec, get_row, scale. + do 2 rewrite Msum_Csum. + apply Csum_eq_bounded; intros. + easy. +Qed. + +Lemma row_add_many_transpose : forall {n m} (A : Matrix n m) (row : nat) (as' : Matrix 1 n), + (row_add_many row as' A)⊤ = col_add_many row (as'⊤) (A⊤). +Proof. intros. + prep_matrix_equality. + unfold row_add_many, col_add_many, transpose. + bdestruct (y =? row); try easy. + apply Csum_simplify; try easy. + unfold gen_new_vec, gen_new_row, get_vec, get_row, scale. + do 2 rewrite Msum_Csum. + apply Csum_eq_bounded; intros. + easy. +Qed. + +Lemma col_add_each_transpose : forall {n m} (A : Matrix n m) (col : nat) (as' : Matrix 1 m), + (col_add_each col as' A)⊤ = row_add_each col (as'⊤) (A⊤). +Proof. intros. + unfold row_add_each, col_add_each. + rewrite Mplus_transpose. + rewrite Mmult_transpose. + rewrite get_vec_transpose. + easy. +Qed. + +Lemma row_add_each_transpose : forall {n m} (A : Matrix n m) (row : nat) (as' : Vector n), + (row_add_each row as' A)⊤ = col_add_each row (as'⊤) (A⊤). +Proof. intros. + unfold row_add_each, col_add_each. + rewrite Mplus_transpose. + rewrite Mmult_transpose. + rewrite get_row_transpose. + easy. +Qed. + +Lemma swap_preserves_mul_lt : forall {n m o} (A : Matrix n m) (B : Matrix m o) (x y : nat), + x < y -> x < m -> y < m -> A × B = (col_swap A x y) × (row_swap B x y). +Proof. intros. + prep_matrix_equality. + unfold Mmult. + bdestruct (x y < m -> A × B = (col_swap A x y) × (row_swap B x y). +Proof. intros. bdestruct (x x < m -> y < m -> A × (row_add B y x a) = (col_add A x y a) × B. +Proof. intros. + prep_matrix_equality. + unfold Mmult. + bdestruct (x y < m -> A × (row_add B y x a) = (col_add A x y a) × B. +Proof. intros. bdestruct (x skip_count skip i. +Proof. intros; unfold skip_count. + bdestruct (i skip_count skip i1 < skip_count skip i2. +Proof. intros; unfold skip_count. + bdestruct (i1 to_add <> col -> + col_add (col_add_many col as' T) col to_add c = + col_add_many col as' (col_add T col to_add c). +Proof. intros. + prep_matrix_equality. + unfold col_add, col_add_many. + bdestruct (y =? col); try lia; try easy. + repeat rewrite <- Cplus_assoc. + apply Csum_simplify; try easy. + bdestruct (to_add =? col); try lia. + rewrite Cplus_comm. + apply Csum_simplify; try easy. + unfold gen_new_vec. + do 2 rewrite Msum_Csum. + apply Csum_eq_bounded; intros. + unfold get_vec, scale; simpl. + bdestruct (x0 =? col); try lca. + rewrite H4, H; lca. +Qed. + + + +Lemma col_add_many_preserves_mul_some : forall (n m o e col : nat) + (A : Matrix n m) (B : Matrix m o) (v : Vector m), + WF_Matrix v -> (skip_count col e) < m -> col < m -> + (forall i : nat, (skip_count col e) < i -> v i 0 = C0) -> v col 0 = C0 -> + A × (row_add_each col v B) = (col_add_many col v A) × B. +Proof. induction e as [| e]. + - intros. + destruct m; try easy. + rewrite (col_add_many_col_add col (skip_count col 0) _ _); try easy. + rewrite <- (col_add_many_0 col A (make_row_zero (skip_count col 0) v)). + rewrite (row_add_each_row_add col (skip_count col 0) _ _); try easy. + rewrite <- (row_add_each_0 col B (make_row_zero (skip_count col 0) v)). + apply col_add_preserves_mul; try easy. + apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv; intros. + destruct j; try lia. + unfold make_row_zero. + bdestruct (i =? skip_count col 0); try lia; try easy. + destruct col; destruct i; try easy. + rewrite H2; try easy. unfold skip_count in *. + bdestruct (0 col < m -> v col 0 = C0 -> + A × (row_add_each col v B) = (col_add_many col v A) × B. +Proof. intros. + destruct m; try easy. + destruct m. + - assert (H' : v = Zero). + apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv; intros. + destruct i; destruct j; destruct col; try lia; easy. + rewrite <- col_add_many_0, <- row_add_each_0; try easy. + rewrite H'; easy. + - apply (col_add_many_preserves_mul_some _ _ _ m col); try easy. + unfold skip_count. + bdestruct (m col < m -> v 0 col = C0 -> + A × (row_add_many col v B) = (col_add_each col v A) × B. +Proof. intros. + assert (H' : ((B⊤) × (row_add_each col (v⊤) (A⊤)))⊤ = + ((col_add_many col (v⊤) (B⊤)) × (A⊤))⊤). + rewrite col_add_many_preserves_mul; auto with wf_db; try easy. + do 2 rewrite Mmult_transpose in H'. + rewrite row_add_each_transpose in H'. + rewrite col_add_many_transpose in H'. + repeat rewrite transpose_involutive in H'. + easy. +Qed. + + +Lemma col_swap_mult_r : forall {n} (A : Square n) (x y : nat), + x < n -> y < n -> WF_Matrix A -> + col_swap A x y = A × (row_swap (I n) x y). +Proof. intros. + assert (H2 := (swap_preserves_mul A (row_swap (I n) x y) x y)). + rewrite <- (Mmult_1_r _ _ (col_swap A x y)); auto with wf_db. + rewrite H2; try easy. + rewrite <- (row_swap_inv (I n) x y). + reflexivity. +Qed. + +Lemma col_scale_mult_r : forall {n} (A : Square n) (x : nat) (a : C), + WF_Matrix A -> + col_scale A x a = A × (row_scale (I n) x a). +Proof. intros. + rewrite scale_preserves_mul. + rewrite Mmult_1_r; auto with wf_db. +Qed. + + +Lemma col_add_many_mult_r : forall {n} (A : Square n) (v : Vector n) (col : nat), + WF_Matrix A -> WF_Matrix v -> col < n -> v col 0 = C0 -> + col_add_many col v A = A × (row_add_each col v (I n)). +Proof. intros. + rewrite col_add_many_preserves_mul; try easy. + rewrite Mmult_1_r; auto with wf_db. +Qed. + + +Lemma col_add_each_mult_r : forall {n} (A : Square n) (v : Matrix 1 n) (col : nat), + WF_Matrix A -> WF_Matrix v -> col < n -> v 0 col = C0 -> + col_add_each col v A = A × (row_add_many col v (I n)). +Proof. intros. + rewrite col_add_each_preserves_mul; try easy. + rewrite Mmult_1_r; auto with wf_db. +Qed. + + + +Lemma reduce_append_split : forall {n m} (T : Matrix n (S m)), + WF_Matrix T -> T = col_append (reduce_col T m) (get_vec m T). +Proof. intros. + prep_matrix_equality. + unfold col_append, get_vec, reduce_col. + bdestruct (y =? S m - 1); bdestruct (0 =? 0); bdestruct (y smash T (@Zero n i) = T. +Proof. intros. + prep_matrix_equality. + unfold smash, Zero. + bdestruct (y WF_Matrix v -> + col_append T v = smash T v. +Proof. intros. + unfold smash, col_append, WF_Matrix in *. + prep_matrix_equality. + bdestruct (y =? m); bdestruct (y v (n - 1) 0 = C0 -> v = reduce_vecn v. +Proof. intros. unfold reduce_vecn. + prep_matrix_equality. + bdestruct (x (v = Zero <-> (reduce_row v x) = Zero /\ v x 0 = C0). +Proof. intros. split. + - intros. rewrite H0. split. + + prep_matrix_equality. unfold reduce_row. + bdestruct (x0 v <> Zero -> exists x, v x 0 <> C0. +Proof. induction n as [| n']. + - intros. + assert (H' : v = Zero). + { prep_matrix_equality. + unfold Zero. + unfold WF_Matrix in H. + apply H. + left. lia. } + easy. + - intros. + destruct (Ceq_dec (v n' 0) C0). + + destruct (vec_equiv_dec (reduce_row v n') Zero). + * assert (H' := H). + apply (zero_reduce _ n') in H'. + destruct H'. + assert (H' : v = Zero). + { apply H2. + split. + apply mat_equiv_eq; auto with wf_db. + easy. } + easy. + * assert (H1 : exists x, (reduce_row v n') x 0 <> C0). + { apply IHn'. + assert (H1' := (@WF_reduce_row (S n') 1 n')). + rewrite easy_sub in *. + apply H1'; try lia; try easy. + unfold not in *. intros. apply n. + rewrite H1. easy. } + destruct H1. + exists x. + rewrite (last_zero_simplification v); try easy. + rewrite rvn_is_rr_n. + all : rewrite easy_sub. + apply H1. + apply e. + + exists n'. + apply n. +Qed. + +(***********************************************************) +(* Defining linear independence, and proving lemmas etc... *) +(***********************************************************) + + +Definition linearly_independent {n m} (T : Matrix n m) : Prop := + forall (a : Vector m), WF_Matrix a -> @Mmult n m 1 T a = Zero -> a = Zero. + + +Definition linearly_dependent {n m} (T : Matrix n m) : Prop := + exists (a : Vector m), WF_Matrix a /\ a <> Zero /\ @Mmult n m 1 T a = Zero. + + +Lemma lindep_implies_not_linindep : forall {n m} (T : Matrix n m), + linearly_dependent T -> ~ (linearly_independent T). +Proof. unfold not, linearly_dependent, linearly_independent in *. + intros. + destruct H as [a [H1 [H2 H3]]]. + apply H0 in H1; easy. +Qed. + + +Lemma not_lindep_implies_linindep : forall {n m} (T : Matrix n m), + not (linearly_dependent T) -> linearly_independent T. +Proof. unfold not, linearly_dependent, linearly_independent in *. + intros. + destruct (vec_equiv_dec a Zero). + - apply mat_equiv_eq; auto with wf_db. + - assert (H2 : (exists a : Vector m, WF_Matrix a /\ a <> Zero /\ T × a = Zero)). + { exists a. + split; auto. + split; try easy. + unfold not; intros. + apply n0. + rewrite H2. + easy. } + apply H in H2. + easy. +Qed. + + + +Lemma lin_indep_vec : forall {n} (v : Vector n), + WF_Matrix v -> v <> Zero -> linearly_independent v. +Proof. intros. + unfold linearly_independent. + intros. + assert (H' : v × a = (a 0 0) .* v). + { apply mat_equiv_eq; auto with wf_db. + unfold Mmult, scale, mat_equiv. + intros. simpl. + destruct j; try lia; lca. } + assert (H1' := H). + apply nonzero_vec_nonzero_elem in H1'; try easy. + destruct H1' as [x H1']. + destruct (Ceq_dec (a 0 0) C0). + + prep_matrix_equality. + destruct x0. destruct y. + rewrite e; easy. + all : apply H1; lia. + + assert (H'' : ((a 0 0) .* v) x 0 = C0). + { rewrite <- H'. rewrite H2; easy. } + unfold scale in H''. + assert (H3 : (a 0 0 * v x 0)%C <> C0). + { apply Cmult_neq_0; easy. } + easy. +Qed. + + +Definition e_i {n : nat} (i : nat) : Vector n := + fun x y => (if (x =? i) && (x (reduce A 0 0) × (reduce_row v 0) = reduce_row (A × v) 0. +Proof. intros. + prep_matrix_equality. + unfold Mmult, reduce, reduce_row. + rewrite easy_sub. + bdestruct (x (reduce A n n) × (reduce_row v n) = reduce_row (A × v) n. +Proof. intros. + prep_matrix_equality. + unfold Mmult, reduce, reduce_row. + assert (H' : S n - 1 = n). { lia. } + bdestruct (x (reduce A x x) × (reduce_row v x) = reduce_row (A × v) x. +Proof. *) + + +(* similar lemma for append *) +Lemma append_mul : forall {n m} (A : Matrix n m) (v : Vector n) (a : Vector m), + (col_append A v) × (row_append a (@Zero 1 1)) = A × a. +Proof. intros. + prep_matrix_equality. + unfold Mmult. + simpl. + assert (H' : (col_append A v x m * row_append a Zero m y = C0)%C). + { unfold col_append, row_append. + bdestruct (m =? m); try lia; lca. } + rewrite H'. + rewrite Cplus_0_r. + apply Csum_eq_bounded. + intros. + unfold col_append, row_append. + bdestruct (x0 =? m); try lia; try easy. +Qed. + + +Lemma invertible_l_implies_linind : forall {n} (A B : Square n), + A × B = I n -> linearly_independent B. +Proof. intros. + unfold linearly_independent. intros. + rewrite <- (Mmult_1_l _ _ a); try easy. + rewrite <- H. + rewrite Mmult_assoc, H1. + rewrite Mmult_0_r. + reflexivity. +Qed. + + +Lemma matrix_by_basis : forall {n m} (T : Matrix n m) (i : nat), + i < m -> get_vec i T = T × e_i i. +Proof. intros. unfold get_vec, e_i, Mmult. + prep_matrix_equality. + bdestruct (y =? 0). + - rewrite (Csum_unique (T x i) _ m); try easy. + exists i. split. + apply H. split. + bdestruct (i =? i); bdestruct (i (get_vec i T) = Zero -> linearly_dependent T. +Proof. intros. + unfold linearly_dependent in *; intros. + exists (@e_i m i). + split. apply WF_e_i. + split. + unfold not; intros. + assert (H' : (@e_i m i) i 0 = C0). + { rewrite H1; easy. } + unfold e_i in H'; simpl in H'. + bdestruct (i =? i); bdestruct (i (forall i, i < m -> (get_vec i T) <> Zero). +Proof. intros. unfold not. intros. + apply (zero_vec_lin_dep T i) in H0; try easy. + apply lindep_implies_not_linindep in H0. + easy. +Qed. + + +Lemma lin_indep_col_reduce_n : forall {n m} (A : Matrix n (S m)), + linearly_independent A -> linearly_independent (reduce_col A m). +Proof. intros. + unfold linearly_independent in *. + intros. + assert (H' : row_append a Zero = Zero). + { apply H. + rewrite easy_sub in *. + apply WF_row_append; try easy. + prep_matrix_equality. + unfold Mmult, row_append, Zero. + rewrite <- Csum_extend_r. + bdestruct (m =? S m - 1); try lia. + autorewrite with C_db. + assert (H' : (reduce_col A m × a) x y = C0). + { rewrite H1; easy. } + rewrite <- H'. + unfold Mmult. + rewrite easy_sub. + apply Csum_eq_bounded. + intros. + unfold reduce_col. + bdestruct (x0 =? m); bdestruct (x0 linearly_independent A1. +Proof. induction m2 as [| m2']. + - intros. + unfold linearly_independent in *. + intros. assert (H' : m1 + 0 = m1). lia. + rewrite H' in *. + apply H; try easy. + rewrite <- H1. + unfold smash, Mmult. + prep_matrix_equality. + apply Csum_eq_bounded. + intros. + bdestruct (x0 linearly_dependent (col_append A v). +Proof. intros. + unfold linearly_dependent in *. + destruct H as [a [H [H1 H2]]]. + exists (row_append a (@Zero 1 1)). + split; auto with wf_db. + split. unfold not; intros; apply H1. + prep_matrix_equality. + assert (H' : row_append a Zero x y = C0). + { rewrite H0. easy. } + unfold row_append in H'. + bdestruct (x =? m). + rewrite H; try easy; lia. + rewrite H'; easy. + rewrite append_mul. + easy. +Qed. + + + +Lemma lin_indep_swap : forall {n m} (T : Matrix n m) (x y : nat), + x < m -> y < m -> linearly_independent T -> linearly_independent (col_swap T x y). +Proof. intros. + unfold linearly_independent in *. + intros. + rewrite (row_swap_inv a x y) in H3. + rewrite <- (swap_preserves_mul T (row_swap a x y) x y) in H3; try easy. + apply H1 in H3. + rewrite (row_swap_inv a x y). + rewrite H3. + prep_matrix_equality. + unfold row_swap. + bdestruct (x0 =? x); bdestruct (x0 =? y); easy. + apply WF_row_swap; easy. +Qed. + +Lemma lin_indep_swap_conv : forall {n m} (T : Matrix n m) (x y : nat), + x < m -> y < m -> linearly_independent (col_swap T x y) -> linearly_independent T. +Proof. intros. + rewrite (col_swap_inv T x y). + apply lin_indep_swap; easy. +Qed. + + +Lemma lin_indep_scale : forall {n m} (T : Matrix n m) (x : nat) (c : C), + c <> C0 -> linearly_independent T -> linearly_independent (col_scale T x c). +Proof. intros. + unfold linearly_independent in *. + intros. + rewrite <- scale_preserves_mul in H2. + apply H0 in H2. + rewrite (row_scale_inv _ x c); try easy. + rewrite H2. + prep_matrix_equality. + unfold row_scale. + bdestruct (x0 =? x); + lca. + apply WF_row_scale; easy. +Qed. + + +Lemma lin_indep_scale_conv : forall {n m} (T : Matrix n m) (x : nat) (c : C), + c <> C0 -> linearly_independent (col_scale T x c) -> linearly_independent T. +Proof. intros. + rewrite (col_scale_inv T x c); try easy. + apply lin_indep_scale; try apply nonzero_div_nonzero; easy. +Qed. + + +Lemma lin_indep_add : forall {n m} (T : Matrix n m) (x y : nat) (c : C), + x <> y -> x < m -> y < m -> linearly_independent T -> linearly_independent (col_add T x y c). +Proof. intros. + unfold linearly_independent in *. + intros. + rewrite <- col_add_preserves_mul in H4; try easy. + apply H2 in H4. + rewrite (row_add_inv a y x c); try lia. + rewrite H4. + prep_matrix_equality. + unfold row_add. + bdestruct (x0 =? y); + lca. + apply WF_row_add; easy. +Qed. + + + + +Lemma lin_indep_col_add_many_some : forall (e n m col : nat) (T : Matrix n m) (as' : Vector m), + (skip_count col e) < m -> col < m -> + (forall i : nat, (skip_count col e) < i -> as' i 0 = C0) -> as' col 0 = C0 -> + linearly_independent T -> linearly_independent (col_add_many col as' T). +Proof. induction e as [| e]. + - intros. + rewrite (col_add_many_col_add _ (skip_count col 0)); + try lia; try easy. + apply lin_indep_add; try lia. + apply skip_count_not_skip. + assert (H' : (col_add_many col (make_row_zero (skip_count col 0) as') T) = T). + { prep_matrix_equality. + unfold col_add_many, make_row_zero, skip_count, gen_new_vec, scale in *. + bdestruct (y =? col); try lia; try easy. + rewrite <- Cplus_0_l. + rewrite Cplus_comm. + apply Csum_simplify; try easy. + rewrite Msum_Csum. + apply Csum_0_bounded; intros. + destruct col; simpl in *. + bdestruct (x0 =? 1); try lca. + destruct x0; try rewrite H2; try rewrite H1; try lca; try lia. + destruct x0; try lca; rewrite H1; try lca; lia. } + rewrite H'; easy. + apply skip_count_not_skip. + - intros. + rewrite (col_add_many_col_add _ (skip_count col (S e))); + try lia; try easy. + apply lin_indep_add; try lia. + apply skip_count_not_skip. + apply IHe; try lia; try easy; auto with wf_db. + assert (H' : e < S e). lia. + apply (skip_count_mono col) in H'. + lia. + intros. + unfold skip_count, make_row_zero in *. + bdestruct (e as' col 0 = C0 -> linearly_independent T -> + linearly_independent (col_add_many col as' T). +Proof. intros. + destruct m; try lia. + destruct m. + - assert (H' : as' == Zero). + { unfold mat_equiv; intros. + destruct col; destruct i; destruct j; try lia. + easy. } + rewrite <- col_add_many_0; easy. + - rewrite (col_add_many_mat_equiv _ _ _ (make_WF as')); + try apply mat_equiv_make_WF. + bdestruct (col =? S m). + + apply (lin_indep_col_add_many_some m); try lia; try easy. + unfold skip_count. bdestruct (m as' col 0 = C0 -> + linearly_independent (col_add_many col as' T) -> + linearly_independent T. +Proof. intros. + rewrite (col_add_many_inv T col as'); try easy. + apply lin_indep_col_add_many; try easy. + unfold scale; rewrite H0. + lca. +Qed. + + + +Lemma lin_indep_col_add_each_some : forall (e n m col : nat) (as' : Matrix 1 m) (T : Matrix n m), + WF_Matrix as' -> (skip_count col e) < m -> col < m -> + (forall i : nat, (skip_count col e) < i -> as' 0 i = C0) -> as' 0 col = C0 -> + linearly_independent T -> linearly_independent (col_add_each col as' T). +Proof. induction e as [| e]. + - intros. + rewrite (col_add_each_col_add _ (skip_count col 0)); try lia. + apply lin_indep_add; try lia. + assert (H' := skip_count_not_skip col 0). auto. + assert (H' : (make_col_zero (skip_count col 0) as') = Zero). + { apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv; intros. + unfold make_col_zero, skip_count in *. + destruct i; try lia. + destruct col; simpl in *. + all : destruct j; try easy; simpl. + destruct j; try easy; simpl. + all : apply H2; lia. } + rewrite H'. + rewrite <- col_add_each_0; easy. + apply skip_count_not_skip. + intros x. destruct x; try easy. + apply H; lia. + - intros. + rewrite (col_add_each_col_add _ (skip_count col (S e))); try lia. + apply lin_indep_add; try lia. + assert (H' := skip_count_not_skip col (S e)). auto. + apply IHe; try lia; try easy; auto with wf_db. + assert (H' : e < S e). lia. + apply (skip_count_mono col) in H'. + lia. + intros. + unfold skip_count, make_col_zero in *. + bdestruct (e WF_Matrix as' -> linearly_independent T -> + linearly_independent (col_add_each col (make_col_zero col as') T). +Proof. intros. + destruct m. + - assert (H' : make_col_zero col as' = Zero). + { apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv; intros. + destruct col; destruct i; destruct j; try lia. + unfold make_col_zero. + easy. } + rewrite H'. + rewrite <- col_add_each_0; easy. + - bdestruct (col =? S m). + + apply (lin_indep_col_add_each_some m); try lia; try easy; auto with wf_db. + unfold skip_count. bdestruct (m y < m -> linearly_dependent T -> linearly_dependent (col_swap T x y). +Proof. unfold linearly_dependent in *. + intros. + destruct H1 as [a [H1 [H2 H3]]]. + rewrite (row_swap_inv a x y) in H3. + rewrite (col_swap_inv T x y) in H3. + rewrite <- (swap_preserves_mul _ (row_swap a x y) x y) in H3; try easy. + exists (row_swap a x y). + split; auto with wf_db. + split; try easy; unfold not in *. + intros; apply H2. + rewrite (row_swap_inv a x y). + rewrite H4. + prep_matrix_equality. + unfold Zero, row_swap. + bdestruct (x0 =? x); bdestruct (x0 =? y); easy. +Qed. + + +Lemma lin_dep_swap_conv : forall {n m} (T : Matrix n m) (x y : nat), + x < m -> y < m -> linearly_dependent (col_swap T x y) -> linearly_dependent T. +Proof. intros. + rewrite (col_swap_inv T x y). + apply lin_dep_swap; easy. +Qed. + + +Lemma lin_dep_scale : forall {n m} (T : Matrix n m) (x : nat) (c : C), + linearly_dependent T -> linearly_dependent (col_scale T x c). +Proof. intros. + destruct (Ceq_dec c C0). + - bdestruct (x C0 -> linearly_dependent (col_scale T x c) -> linearly_dependent T. +Proof. intros. + rewrite (col_scale_inv T x c); try easy. + apply lin_dep_scale; easy. +Qed. + + +Lemma lin_dep_add : forall {n m} (T : Matrix n m) (x y : nat) (c : C), + x <> y -> x < m -> y < m -> linearly_dependent T -> linearly_dependent (col_add T x y c). +Proof. intros. + unfold linearly_dependent in *. + destruct H2 as [a [H2 [H3 H4]]]. + exists (row_add a y x (- c)). + split; auto with wf_db. + split. unfold not; intros; apply H3. + rewrite (row_add_inv a y x (- c)); try lia. + rewrite H5. + unfold row_add, Zero. + prep_matrix_equality. + bdestruct (x0 =? y); lca. + rewrite col_add_preserves_mul; try easy. + rewrite <- (col_add_inv T x y c); try lia; easy. +Qed. + + +Lemma lin_dep_col_add_many_some : forall (e n m col : nat) (T : Matrix n m) (as' : Vector m), + (skip_count col e) < m -> col < m -> + (forall i : nat, (skip_count col e) < i -> as' i 0 = C0) -> as' col 0 = C0 -> + linearly_dependent T -> linearly_dependent (col_add_many col as' T). +Proof. induction e as [| e]. + - intros. + rewrite (col_add_many_col_add _ (skip_count col 0)); + try lia; try easy. + apply lin_dep_add; try lia. + apply skip_count_not_skip. + assert (H' : (col_add_many col (make_row_zero (skip_count col 0) as') T) = T). + { prep_matrix_equality. + unfold col_add_many, make_row_zero, skip_count, gen_new_vec, scale in *. + bdestruct (y =? col); try lia; try easy. + rewrite <- Cplus_0_l. + rewrite Cplus_comm. + apply Csum_simplify; try easy. + rewrite Msum_Csum. + apply Csum_0_bounded; intros. + destruct col; simpl in *. + bdestruct (x0 =? 1); try lca. + destruct x0; try rewrite H2; try rewrite H1; try lca; try lia. + destruct x0; try lca; rewrite H1; try lca; lia. } + rewrite H'; easy. + apply skip_count_not_skip. + - intros. + rewrite (col_add_many_col_add _ (skip_count col (S e))); + try lia; try easy. + apply lin_dep_add; try lia. + apply skip_count_not_skip. + apply IHe; try lia; try easy; auto with wf_db. + assert (H' : e < S e). lia. + apply (skip_count_mono col) in H'. + lia. + intros. + unfold skip_count, make_row_zero in *. + bdestruct (e as' col 0 = C0 -> linearly_dependent T -> + linearly_dependent (col_add_many col as' T). +Proof. intros. + destruct m; try lia. + destruct m. + - assert (H' : as' == Zero). + { unfold mat_equiv; intros. + destruct col; destruct i; destruct j; try lia. + easy. } + rewrite <- col_add_many_0; easy. + - rewrite (col_add_many_mat_equiv _ _ _ (make_WF as')); + try apply mat_equiv_make_WF. + bdestruct (col =? S m). + + apply (lin_dep_col_add_many_some m); try lia; try easy. + unfold skip_count. bdestruct (m as' col 0 = C0 -> + linearly_dependent (col_add_many col as' T) -> + linearly_dependent T. +Proof. intros. + rewrite (col_add_many_inv T col as'); try easy. + apply lin_dep_col_add_many; try easy. + unfold scale; rewrite H0. + lca. +Qed. + + +Lemma lin_dep_col_add_each_some : forall (e n m col : nat) (as' : Matrix 1 m) (T : Matrix n m), + WF_Matrix as' -> (skip_count col e) < m -> col < m -> + (forall i : nat, (skip_count col e) < i -> as' 0 i = C0) -> as' 0 col = C0 -> + linearly_dependent T -> linearly_dependent (col_add_each col as' T). +Proof. induction e as [| e]. + - intros. + rewrite (col_add_each_col_add _ (skip_count col 0)); try lia. + apply lin_dep_add; try lia. + assert (H' := skip_count_not_skip col 0). auto. + assert (H' : (make_col_zero (skip_count col 0) as') = Zero). + { apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv; intros. + unfold make_col_zero, skip_count in *. + destruct i; try lia. + destruct col; simpl in *. + all : destruct j; try easy; simpl. + destruct j; try easy; simpl. + all : apply H2; lia. } + rewrite H'. + rewrite <- col_add_each_0; easy. + assert (H' := skip_count_not_skip col 0). auto. + intros. destruct x; try easy. + apply H; lia. + - intros. + rewrite (col_add_each_col_add _ (skip_count col (S e))); try lia. + apply lin_dep_add; try lia. + assert (H' := skip_count_not_skip col (S e)). auto. + apply IHe; try lia; try easy; auto with wf_db. + assert (H' : e < S e). lia. + apply (skip_count_mono col) in H'. + lia. + intros. + unfold skip_count, make_col_zero in *. + bdestruct (e WF_Matrix as' -> linearly_dependent T -> + linearly_dependent (col_add_each col (make_col_zero col as') T). +Proof. intros. + destruct m. + - assert (H' : make_col_zero col as' = Zero). + { apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv; intros. + destruct col; destruct i; destruct j; try lia. + unfold make_col_zero. + easy. } + rewrite H'. + rewrite <- col_add_each_0; easy. + - bdestruct (col =? S m). + + apply (lin_dep_col_add_each_some m); try lia; try easy; auto with wf_db. + unfold skip_count. bdestruct (m WF_Matrix as' -> + linearly_dependent (col_add_each col (make_col_zero col as') T) -> + linearly_dependent T. +Proof. intros. + rewrite (col_add_each_inv col as'). + apply lin_dep_col_add_each; auto with wf_db. +Qed. + + +Lemma lin_dep_gen_elem : forall {m n} (T : Matrix n (S m)), + WF_Matrix T -> linearly_dependent T -> + (exists i, i < (S m) /\ + (exists v : Vector m, WF_Matrix v /\ + @Mmult n m 1 (reduce_col T i) v = (-C1) .* (get_vec i T))). +Proof. intros. + unfold linearly_dependent in H. + destruct H0 as [a [H1 [H2 H3]]]. + assert (H4 := H1). + apply nonzero_vec_nonzero_elem in H4; try easy. + destruct H4 as [x H4]. + exists x. + bdestruct (x reduce_col T x i y * reduce_row a x y j) m + + (a x 0) * get_vec x T i j = @Zero n 1 i j)%C). + { rewrite <- H3. unfold Mmult. + assert (H'' : m = x + (m - x)). lia. + rewrite H''. + rewrite Csum_sum. + rewrite <- H''. + assert (H2' : S m = x + S (m - x)). lia. + rewrite H2'. + rewrite Csum_sum. + rewrite <- Csum_extend_l. + rewrite <- Cplus_assoc. + apply Csum_simplify. + apply Csum_eq_bounded. + intros. unfold reduce_col, reduce_row. + bdestruct (x0 reduce_col T x i y * reduce_row a x y j) m + + (a x 0) * get_vec x T i j + (a x 0) * (- (get_vec x T i j)) = + (- (a x 0)) * get_vec x T i j)%C). + { rewrite H'. lca. } + rewrite <- Cplus_assoc in H1'. + rewrite <- Cmult_plus_distr_l in H1'. + rewrite Cplus_opp_r in H1'. + rewrite Cmult_0_r, Cplus_0_r in H1'. + rewrite H1'. + rewrite Cmult_assoc. + rewrite <- Copp_mult_distr_r. + rewrite Cinv_l; easy. + - assert (H' : a x 0 = C0). + apply H1; try lia. + easy. +Qed. + + +Lemma gt_dim_lindep_ind_step1 : forall {n m} (T : Matrix (S n) (S m)) (col : nat), + WF_Matrix T -> col <= m -> get_vec col T = @e_i (S n) 0 -> + linearly_dependent (reduce_row (reduce_col T col) 0) -> linearly_dependent T. +Proof. intros. + apply (lin_dep_col_add_each_conv _ _ col (-C1 .* (get_row 0 T))); + auto with wf_db; try lia. + unfold linearly_dependent in *. + destruct H2 as [a [H3 [H4 H5]]]. + repeat rewrite easy_sub in *. + exists (row_wedge a (@Zero 1 1) col). + split. + - rewrite easy_sub in *. + auto with wf_db. + - split. + + unfold not in *. + intros. apply H4. + prep_matrix_equality. + bdestruct (x col < S m -> v col 0 = C0 -> + reduce_col (reduce_row T 0) col × (reduce_row v col) = + - C1 .* get_vec col (reduce_row T 0) -> + linearly_dependent (reduce_row (reduce_col T col) 0) -> linearly_dependent T. +Proof. intros. + assert (H' := @col_add_many_cancel n (S m) (reduce_row T 0) v col). + assert (H0' : forall i : nat, @col_add_many n (S m) col v (reduce_row T 0) i col = C0). + { repeat rewrite easy_sub in *; apply H'; try easy. } + repeat rewrite easy_sub in *. + apply (lin_dep_col_add_many_conv _ _ col _ v); try easy. + destruct (Ceq_dec ((col_add_many col v T) 0 col) C0). + - apply (zero_vec_lin_dep _ col); try lia. + prep_matrix_equality. unfold get_vec. + destruct y; try easy; simpl. + destruct x; try easy. unfold Zero. + rewrite <- (H0' x). + unfold col_add_many, reduce_row. + bdestruct (col =? col); bdestruct (x WF_Matrix T -> linearly_dependent T. +Proof. induction m as [| m']. + - intros; lia. + - intros. + destruct n as [| n']. + + exists (e_i 0). + split. apply WF_e_i. + split. unfold not; intros. + assert (H' : (@e_i (S m') 0) 0 0 = C0). + { rewrite H1; easy. } + unfold e_i in H'; simpl in H'. + apply C1_neq_C0; easy. + assert (H' : T = Zero). + { prep_matrix_equality. + rewrite H0; try easy; try lia. } + rewrite H'. apply Mmult_0_l. + + bdestruct (n' WF_Matrix (pad A c). +Proof. unfold WF_Matrix, pad. split. + - intros. + unfold col_wedge, row_wedge, e_i, scale. + bdestruct (y j -> A i j = C0) -> A 0 0 = c -> + exists a : Square n, pad a c = A. +Proof. intros. + exists (reduce A 0 0). + unfold pad, reduce, col_wedge, row_wedge, e_i, scale. + prep_matrix_equality. + bdestruct (y linearly_independent A. +Proof. unfold linearly_independent. + intros. + assert (H2 : (pad A c) × (row_wedge a Zero 0) = Zero). + { prep_matrix_equality. + destruct x. unfold Mmult. + unfold Zero. apply Csum_0_bounded. + intros. + unfold pad, row_wedge, col_wedge, e_i, scale. + bdestruct (x linearly_independent A -> + (exists B : Square (S n), WF_Matrix B /\ linearly_independent (A × B) /\ + (exists i, i < (S n) /\ get_vec i (A × B) = e_i 0)). +Proof. intros. + assert (H1 : WF_Matrix (reduce_row A 0)). + { assert (H1' := (@WF_reduce_row (S n) (S n))). + rewrite easy_sub in *. + apply H1'; try lia; easy. } + assert (H2 : linearly_dependent (reduce_row A 0)). + { apply gt_dim_lindep; try lia. + apply H1. } + apply lin_dep_gen_elem in H2; try easy. + destruct H2 as [i [H2 H3]]. + destruct H3 as [v [H3 H4]]. + apply (lin_indep_col_add_many (S n) (S n) i A (row_wedge v Zero i)) in H0; try easy. + destruct (Ceq_dec ((col_add_many i (row_wedge v Zero i) A) 0 i) C0). + - assert (H5 : forall i0 : nat, + col_add_many i (row_wedge v Zero i) (reduce_row A 0) i0 i = C0). + apply (col_add_many_cancel (reduce_row A 0) (row_wedge v Zero i) i); try easy. + unfold row_wedge. + bdestruct (i linearly_independent A -> (exists i, i < (S n) /\ get_vec i A = e_i 0) -> + (exists B : Square (S n), WF_Matrix B /\ linearly_independent (A × B) /\ + (exists a : Square n, pad a C1 = (A × B))). +Proof. intros. + destruct H1 as [i [H1 H2]]. + apply (lin_indep_swap A 0 i) in H0; try lia; try easy. + apply (lin_indep_col_add_each _ _ 0 + (-C1 .* (get_row 0 (col_swap A 0 i))) (col_swap A 0 i)) in H0; try lia. + exists ((row_swap (I (S n)) 0 i) × (row_add_many 0 + (make_col_zero 0 (-C1 .* (get_row 0 (col_swap A 0 i)))) + (I (S n)))). + split. + apply WF_mult. + apply WF_row_swap; try lia; auto with wf_db. + apply WF_row_add_many; try lia; auto with wf_db. + rewrite <- Mmult_assoc. + rewrite <- col_swap_mult_r; try lia; try easy. + rewrite <- col_add_each_mult_r; try lia; try easy. + split; try easy. + apply padded; intros. + destruct H3 as [H3 H4]. + destruct H3. + + unfold col_add_each, make_col_zero, get_row, col_swap, + Mplus, Mmult, get_vec, scale. + rewrite H3 in *. + bdestruct (j =? 0); try lia. + assert (H' : (get_vec i A) 0 0 = C1). + { rewrite H2. easy. } + simpl. bdestruct (j =? i); try lia. + all : unfold get_vec in H'; simpl in H'. + all : rewrite H'; lca. + + unfold col_add_each, make_col_zero, get_row, col_swap, + Mplus, Mmult, get_vec, scale. + rewrite H3 in *; simpl. + destruct i0; try lia. + assert (H' : (get_vec i A) (S i0) 0 = C0). + { rewrite H2. easy. } + unfold get_vec in H'; simpl in H'. + rewrite H'; lca. + + unfold col_add_each, make_col_zero, get_row, col_swap, + Mplus, Mmult, get_vec, scale; simpl. + assert (H' : (get_vec i A) 0 0 = C1). + { rewrite H2. easy. } + unfold get_vec in H'; simpl in H'. + rewrite H'; lca. + + apply WF_col_swap; try lia; easy. + + apply WF_make_col_zero. + apply WF_scale. + apply WF_get_row. + apply WF_col_swap; try lia; easy. + + apply WF_scale. + apply WF_get_row. + apply WF_col_swap; try lia; easy. +Qed. + + +Theorem lin_ind_implies_invertible_r : forall {n} (A : Square n), + WF_Matrix A -> linearly_independent A -> + (exists B, WF_Matrix B /\ A × B = I n). +Proof. induction n as [| n']. + - intros. + exists Zero. split; auto with wf_db. + rewrite Mmult_0_r. + apply mat_equiv_eq; auto with wf_db. + unfold mat_equiv. lia. + - intros. apply lin_indep_ind_step1 in H0; try easy. + destruct H0 as [B1 [H0 [H1 H2]]]. + destruct H2 as [i [H2 H3]]. + apply lin_indep_ind_step2 in H1; auto with wf_db. + destruct H1 as [B2 [H1 [H4 H5]]]. + destruct H5 as [a H5]. + rewrite <- H5 in H4. + apply lin_indep_pad in H4. + apply IHn' in H4. + destruct H4 as [B3 [H6 H7]]. + exists (B1 × B2 × (pad B3 C1)). + split. apply WF_mult. + apply WF_mult; easy. + apply (WF_pad B3 C1). easy. + do 2 rewrite <- Mmult_assoc. + rewrite <- H5. + rewrite <- pad_mult. + rewrite Cmult_1_l. + rewrite H7, pad_I; easy. + apply (WF_pad a C1). + rewrite H5. + auto with wf_db. + exists i; split; try lia. + easy. +Qed. + + + + +(* Inverses of square matrices *) + +Definition Minv {n : nat} (A B : Square n) : Prop := A × B = I n /\ B × A = I n. + + +Definition invertible {n : nat} (A : Square n) : Prop := + exists B, Minv A B. + + +Lemma Minv_unique : forall (n : nat) (A B C : Square n), + WF_Matrix A -> WF_Matrix B -> WF_Matrix C -> + Minv A B -> Minv A C -> B = C. +Proof. + intros n A B C WFA WFB WFC [HAB HBA] [HAC HCA]. + replace B with (B × I n) by (apply Mmult_1_r; assumption). + rewrite <- HAC. + replace C with (I n × C) at 2 by (apply Mmult_1_l; assumption). + rewrite <- HBA. + rewrite Mmult_assoc. + reflexivity. +Qed. + +Lemma Minv_symm : forall (n : nat) (A B : Square n), Minv A B -> Minv B A. +Proof. unfold Minv; intuition. Qed. + +(* The left inverse of a square matrix is also its right inverse *) +Lemma Minv_flip : forall (n : nat) (A B : Square n), + WF_Matrix A -> WF_Matrix B -> + A × B = I n -> B × A = I n. +Proof. intros. + assert (H3 := H1). + apply invertible_l_implies_linind in H1. + apply lin_ind_implies_invertible_r in H1; try easy. + destruct H1 as [A' [H2 H4]]. + assert (H' : (A × B) × A' = A'). + { rewrite H3. apply Mmult_1_l; easy. } + rewrite Mmult_assoc in H'. + rewrite H4 in H'. + rewrite Mmult_1_r in H'; try easy. + rewrite H'; easy. +Qed. + +Lemma Minv_left : forall (n : nat) (A B : Square n), + WF_Matrix A -> WF_Matrix B -> + A × B = I n -> Minv A B. +Proof. + intros n A B H H0 H1. + unfold Minv. split; trivial. + apply Minv_flip; + assumption. +Qed. + +Lemma Minv_right : forall (n : nat) (A B : Square n), + WF_Matrix A -> WF_Matrix B -> + B × A = I n -> Minv A B. +Proof. + intros n A B H H0. + unfold Minv. split; trivial. + apply Minv_flip; + assumption. +Qed. + + +Lemma lin_indep_invertible : forall {n : nat} (A : Square n), + WF_Matrix A -> (linearly_independent A <-> invertible A). +Proof. intros; split. + - intros. + assert (H1 := H). + apply lin_ind_implies_invertible_r in H; try easy. + destruct H as [B [H H2]]. + unfold invertible. + exists B. unfold Minv. + split; try easy. + apply Minv_flip in H2; easy. + - intros. + destruct H0 as [B [H1 H2]]. + apply invertible_l_implies_linind in H2. + easy. +Qed. + +Lemma div_mod : forall (x y z : nat), (x / y) mod z = (x mod (y * z)) / y. +Proof. + intros. bdestruct (y =? 0). subst. simpl. + bdestruct (z =? 0). subst. easy. + apply Nat.mod_0_l. easy. + bdestruct (z =? 0). subst. rewrite Nat.mul_0_r. simpl. rewrite Nat.div_0_l; easy. + pattern x at 1. rewrite (Nat.div_mod x (y * z)) by nia. + replace (y * z * (x / (y * z))) with ((z * (x / (y * z))) * y) by lia. + rewrite Nat.div_add_l with (b := y) by easy. + replace (z * (x / (y * z)) + x mod (y * z) / y) with + (x mod (y * z) / y + (x / (y * z)) * z) by lia. + rewrite Nat.mod_add by easy. + apply Nat.mod_small. + apply Nat.div_lt_upper_bound. easy. apply Nat.mod_upper_bound. nia. +Qed. + +Lemma sub_mul_mod : + forall x y z, + y * z <= x -> + (x - y * z) mod z = x mod z. +Proof. + intros. bdestruct (z =? 0). subst. easy. + specialize (le_plus_minus_r (y * z) x H) as G. + remember (x - (y * z)) as r. + rewrite <- G. rewrite <- Nat.add_mod_idemp_l by easy. rewrite Nat.mod_mul by easy. + easy. +Qed. + +Lemma mod_product : forall x y z, y <> 0 -> x mod (y * z) mod z = x mod z. +Proof. + intros x y z H. bdestruct (z =? 0). subst. easy. + pattern x at 2. rewrite Nat.mod_eq with (b := y * z) by nia. + replace (y * z * (x / (y * z))) with (y * (x / (y * z)) * z) by lia. + rewrite sub_mul_mod. easy. + replace (y * (x / (y * z)) * z) with (y * z * (x / (y * z))) by lia. + apply Nat.mul_div_le. nia. +Qed. + +Lemma kron_assoc_mat_equiv : forall {m n p q r s : nat} + (A : Matrix m n) (B : Matrix p q) (C : Matrix r s), + (A ⊗ B ⊗ C) == A ⊗ (B ⊗ C). +Proof. + intros. intros i j Hi Hj. + remember (A ⊗ B ⊗ C) as LHS. + unfold kron. + rewrite (mult_comm p r) at 1 2. + rewrite (mult_comm q s) at 1 2. + assert (m * p * r <> 0) by lia. + assert (n * q * s <> 0) by lia. + apply Nat.neq_mul_0 in H as [Hmp Hr]. + apply Nat.neq_mul_0 in Hmp as [Hm Hp]. + apply Nat.neq_mul_0 in H0 as [Hnq Hs]. + apply Nat.neq_mul_0 in Hnq as [Hn Hq]. + rewrite <- 2 Nat.div_div by assumption. + rewrite <- 2 div_mod. + rewrite 2 mod_product by assumption. + rewrite Cmult_assoc. + subst. + reflexivity. +Qed. + +Lemma kron_assoc : forall {m n p q r s : nat} + (A : Matrix m n) (B : Matrix p q) (C : Matrix r s), + WF_Matrix A -> WF_Matrix B -> WF_Matrix C -> + (A ⊗ B ⊗ C) = A ⊗ (B ⊗ C). +Proof. + intros. + apply mat_equiv_eq; auto with wf_db. + apply WF_kron; auto with wf_db; lia. + apply kron_assoc_mat_equiv. +Qed. + + +Lemma kron_mixed_product : forall {m n o p q r : nat} (A : Matrix m n) (B : Matrix p q ) + (C : Matrix n o) (D : Matrix q r), (A ⊗ B) × (C ⊗ D) = (A × C) ⊗ (B × D). +Proof. + intros m n o p q r A B C D. + unfold kron, Mmult. + prep_matrix_equality. + destruct q. + + simpl. + rewrite mult_0_r. + simpl. + rewrite Cmult_0_r. + reflexivity. + + rewrite Csum_product. + apply Csum_eq. + apply functional_extensionality. + intros; lca. + lia. +Qed. + +(* Arguments kron_mixed_product [m n o p q r]. *) + + +(* A more explicit version, for when typechecking fails *) +Lemma kron_mixed_product' : forall (m n n' o p q q' r mp nq or: nat) + (A : Matrix m n) (B : Matrix p q) (C : Matrix n' o) (D : Matrix q' r), + n = n' -> q = q' -> + mp = m * p -> nq = n * q -> or = o * r -> + (@Mmult mp nq or (@kron m n p q A B) (@kron n' o q' r C D)) = + (@kron m o p r (@Mmult m n o A C) (@Mmult p q r B D)). +Proof. intros. subst. apply kron_mixed_product. Qed. + + +Lemma outer_product_eq : forall m (φ ψ : Matrix m 1), + φ = ψ -> outer_product φ φ = outer_product ψ ψ. +Proof. congruence. Qed. + +Lemma outer_product_kron : forall m n (φ : Matrix m 1) (ψ : Matrix n 1), + outer_product φ φ ⊗ outer_product ψ ψ = outer_product (φ ⊗ ψ) (φ ⊗ ψ). +Proof. + intros. unfold outer_product. + specialize (kron_adjoint φ ψ) as KT. + simpl in *. rewrite KT. + specialize (kron_mixed_product φ ψ (φ†) (ψ†)) as KM. + simpl in *. rewrite KM. + reflexivity. +Qed. + +Lemma kron_n_assoc : + forall n {m1 m2} (A : Matrix m1 m2), WF_Matrix A -> (S n) ⨂ A = A ⊗ (n ⨂ A). +Proof. + intros. induction n. + - simpl. + rewrite kron_1_r. + rewrite kron_1_l; try assumption. + reflexivity. + - simpl. + replace (m1 * (m1 ^ n)) with ((m1 ^ n) * m1) by apply Nat.mul_comm. + replace (m2 * (m2 ^ n)) with ((m2 ^ n) * m2) by apply Nat.mul_comm. + rewrite <- kron_assoc; auto with wf_db. + rewrite <- IHn. + reflexivity. +Qed. + +Lemma kron_n_adjoint : forall n {m1 m2} (A : Matrix m1 m2), + WF_Matrix A -> (n ⨂ A)† = n ⨂ A†. +Proof. + intros. induction n. + - simpl. apply id_adjoint_eq. + - simpl. + replace (m1 * (m1 ^ n)) with ((m1 ^ n) * m1) by apply Nat.mul_comm. + replace (m2 * (m2 ^ n)) with ((m2 ^ n) * m2) by apply Nat.mul_comm. + rewrite kron_adjoint, IHn. + reflexivity. +Qed. + +Lemma Mscale_kron_n_distr_r : forall {m1 m2} n α (A : Matrix m1 m2), + n ⨂ (α .* A) = (α ^ n) .* (n ⨂ A). +Proof. + intros. + induction n; simpl. + rewrite Mscale_1_l. reflexivity. + rewrite IHn. + rewrite Mscale_kron_dist_r, Mscale_kron_dist_l. + rewrite Mscale_assoc. + reflexivity. +Qed. + +Lemma kron_n_mult : forall {m1 m2 m3} n (A : Matrix m1 m2) (B : Matrix m2 m3), + n ⨂ A × n ⨂ B = n ⨂ (A × B). +Proof. + intros. + induction n; simpl. + rewrite Mmult_1_l. reflexivity. + apply WF_I. + replace (m1 * m1 ^ n) with (m1 ^ n * m1) by apply Nat.mul_comm. +>>>>>>> Heisenberg-Foundations/main + replace (m2 * m2 ^ n) with (m2 ^ n * m2) by apply Nat.mul_comm. + replace (m3 * m3 ^ n) with (m3 ^ n * m3) by apply Nat.mul_comm. + rewrite kron_mixed_product. + rewrite IHn. + reflexivity. +Qed. + +Lemma kron_n_I : forall n, n ⨂ I 2 = I (2 ^ n). +Proof. + intros. + induction n; simpl. + reflexivity. + rewrite IHn. + rewrite id_kron. + apply f_equal. + lia. +Qed. + +Lemma Mmult_n_kron_distr_l : forall {m n} i (A : Square m) (B : Square n), + i ⨉ (A ⊗ B) = (i ⨉ A) ⊗ (i ⨉ B). +Proof. + intros m n i A B. + induction i; simpl. + rewrite id_kron; reflexivity. + rewrite IHi. + rewrite kron_mixed_product. + reflexivity. +Qed. + +Lemma Mmult_n_1_l : forall {n} (A : Square n), + WF_Matrix A -> + 1 ⨉ A = A. +Proof. intros n A WF. simpl. rewrite Mmult_1_r; auto. Qed. + +Lemma Mmult_n_1_r : forall n i, + i ⨉ (I n) = I n. +Proof. + intros n i. + induction i; simpl. + reflexivity. + rewrite IHi. + rewrite Mmult_1_l; auto with wf_db. +Qed. + +Lemma Mmult_n_eigenvector : forall {n} (A : Square n) (ψ : Vector n) λ i, + WF_Matrix ψ -> A × ψ = λ .* ψ -> + i ⨉ A × ψ = (λ ^ i) .* ψ. +Proof. + intros n A ψ λ i WF H. + induction i; simpl. + rewrite Mmult_1_l; auto. + rewrite Mscale_1_l; auto. + rewrite Mmult_assoc. + rewrite IHi. + rewrite Mscale_mult_dist_r. + rewrite H. + rewrite Mscale_assoc. + rewrite Cmult_comm. + reflexivity. +Qed. + +Lemma Msum_eq_bounded : forall {d1 d2} n (f f' : nat -> Matrix d1 d2), + (forall i, (i < n)%nat -> f i = f' i) -> Msum n f = Msum n f'. +Proof. + intros d1 d2 n f f' Heq. + induction n; simpl. + reflexivity. + rewrite Heq by lia. + rewrite IHn. reflexivity. + intros. apply Heq. lia. +Qed. + +Lemma kron_Msum_distr_l : + forall {d1 d2 d3 d4} n (f : nat -> Matrix d1 d2) (A : Matrix d3 d4), + A ⊗ Msum n f = Msum n (fun i => A ⊗ f i). +Proof. + intros. + induction n; simpl. lma. + rewrite kron_plus_distr_l, IHn. reflexivity. +Qed. + +Lemma kron_Msum_distr_r : + forall {d1 d2 d3 d4} n (f : nat -> Matrix d1 d2) (A : Matrix d3 d4), + Msum n f ⊗ A = Msum n (fun i => f i ⊗ A). +Proof. + intros. + induction n; simpl. lma. + rewrite kron_plus_distr_r, IHn. reflexivity. +Qed. + +Lemma Mmult_Msum_distr_l : forall {d1 d2 m} n (f : nat -> Matrix d1 d2) (A : Matrix m d1), + A × Msum n f = Msum n (fun i => A × f i). +Proof. + intros. + induction n; simpl. + rewrite Mmult_0_r. reflexivity. + rewrite Mmult_plus_distr_l, IHn. reflexivity. +Qed. + +Lemma Mmult_Msum_distr_r : forall {d1 d2 m} n (f : nat -> Matrix d1 d2) (A : Matrix d2 m), + Msum n f × A = Msum n (fun i => f i × A). +Proof. + intros. + induction n; simpl. + rewrite Mmult_0_l. reflexivity. + rewrite Mmult_plus_distr_r, IHn. reflexivity. +Qed. + +Lemma Mscale_Msum_distr_r : forall {d1 d2} x n (f : nat -> Matrix d1 d2), + x .* Msum n f = Msum n (fun i => x .* f i). +Proof. + intros d1 d2 x n f. + induction n; simpl. lma. + rewrite Mscale_plus_distr_r, IHn. reflexivity. +Qed. + +Lemma Mscale_Msum_distr_l : forall {d1 d2} n (f : nat -> C) (A : Matrix d1 d2), + Msum n (fun i => (f i) .* A) = Csum f n .* A. +Proof. + intros d1 d2 n f A. + induction n; simpl. lma. + rewrite Mscale_plus_distr_l, IHn. reflexivity. +Qed. + +Lemma Msum_0 : forall {d1 d2} n (f : nat -> Matrix d1 d2), + (forall x, x < n -> f x = Zero) -> Msum n f = Zero. +Proof. + intros d1 d2 n f Hf. + induction n; simpl. reflexivity. + rewrite IHn, Hf. lma. + lia. intros. apply Hf. lia. +Qed. + +Lemma Msum_constant : forall {d1 d2} n (A : Matrix d1 d2), Msum n (fun _ => A) = INR n .* A. +Proof. + intros. + induction n. + simpl. lma. + simpl Msum. + rewrite IHn. + replace (S n) with (n + 1)%nat by lia. + rewrite plus_INR; simpl. + rewrite RtoC_plus. + rewrite Mscale_plus_distr_l. + lma. +Qed. + +Lemma Msum_plus : forall {d1 d2} n (f1 f2 : nat -> Matrix d1 d2), + Msum n (fun i => (f1 i) .+ (f2 i)) = Msum n f1 .+ Msum n f2. +Proof. + intros d1 d2 n f1 f2. + induction n; simpl. lma. + rewrite IHn. lma. +Qed. + +Lemma Msum_adjoint : forall {d1 d2} n (f : nat -> Matrix d1 d2), + (Msum n f)† = Msum n (fun i => (f i)†). +Proof. + intros. + induction n; simpl. + lma. + rewrite Mplus_adjoint, IHn. + reflexivity. +Qed. + +<<<<<<< HEAD +Lemma Msum_Csum : forall {d1 d2} n (f : nat -> Matrix d1 d2) i j, + Msum n f i j = Csum (fun x => f x i j) n. +Proof. + intros. + induction n; simpl. + reflexivity. + unfold Mplus. + rewrite IHn. + reflexivity. +Qed. + +======= +>>>>>>> Heisenberg-Foundations/main +Lemma Msum_unique : forall {d1 d2} n (f : nat -> Matrix d1 d2) (A : Matrix d1 d2), + (exists i, i < n /\ f i = A /\ (forall j, j < n -> j <> i -> f j = Zero)) -> + Msum n f = A. +Proof. + intros d1 d2 n f A H. destruct H as [i [? [? H]]]. induction n; try lia. simpl. @@ -1814,7 +5594,11 @@ Ltac restore_dims_rec A := | Matrix ?m'' ?n'' => constr:(@Mplus m' n' A' B') end end +<<<<<<< HEAD | ?c .* ?A => let A' := restore_dims_rec A in +======= + | ?c .* ?AA => let A' := restore_dims_rec A in +>>>>>>> Heisenberg-Foundations/main match type of A' with | Matrix ?m' ?n' => constr:(@scale m' n' c A') end @@ -2135,6 +5919,16 @@ Proof. intros. exists (b - a - 1). lia. Qed. Lemma lt_ex_diff_r : forall a b, a < b -> exists d, b = a + 1 + d. Proof. intros. exists (b - a - 1). lia. Qed. +<<<<<<< HEAD +======= +Ltac bdestruct_all := + repeat match goal with + | |- context[?a bdestruct (a bdestruct (a <=? b) + | |- context[?a =? ?b] => bdestruct (a =? b) + end; try (exfalso; lia). + +>>>>>>> Heisenberg-Foundations/main (* Remove _ < _ from hyps, remove _ - _ from goal *) Ltac remember_differences := repeat match goal with diff --git a/Polynomial.v b/Polynomial.v new file mode 100644 index 0000000..66143f0 --- /dev/null +++ b/Polynomial.v @@ -0,0 +1,64 @@ +Require Import Psatz. +Require Import String. +Require Import Program. +Require Export Complex. +Require Export Matrix. +Require Import List. + + +(* +Require Export CoRN.fta.FTA. +Require Export CoRN.coq_reals.Rreals_iso. +*) + + +(* polynomial represented by a list of coeficients and a degree*) +Definition Polynomial (n : nat) := list (Complex.C). + + +Definition WF_Poly {n : nat} (p : Polynomial n) := + length p = (S n). + +Definition eval_P (n : nat) (p : Polynomial n) (x : Complex.C):= + Csum (fun i => (nth i p C0)* x^i) (S n). + + +(*****************************************************) +(* First, we show that our C is the same as ccorns C *) +(*****************************************************) + + + +(* + +Definition CtoCC (c : Complex.C) : CC_set := Build_CC_set (RasIR (fst c)) (RasIR (snd c)). +Definition CCtoC (c : CC_set) : Complex.C := (IRasR (Re c), IRasR (Im c)). + + +Lemma CasCCasC_id : forall (x : Complex.C), (CCtoC (CtoCC x) = x). +Proof. intros. + unfold CtoCC, CCtoC. + simpl. + do 2 rewrite RasIRasR_id. + rewrite surjective_pairing. + easy. +Qed. + + +(* +Lemma CCasCasCC_id : forall (x : CC_set), (CtoCC (CCtoC x) = x). +Proof. intros. + unfold CtoCC, CCtoC. + simpl. + do 2 rewrite RasIRasR_id. + rewrite surjective_pairing. + easy. +Qed. *) + +*) + + +Theorem Fundamental_Theorem_Algebra : forall {n : nat} (p : Polynomial n), + (n > 0)%nat -> (exists c : (R * R), eval_P n p c = C0). +Proof. Admitted. + diff --git a/Prelim.v b/Prelim.v index 4748da1..bc4fe07 100644 --- a/Prelim.v +++ b/Prelim.v @@ -7,6 +7,10 @@ Require Export List. Export ListNotations. +<<<<<<< HEAD +======= + +>>>>>>> Heisenberg-Foundations/main (* Boolean notations, lemmas *) Notation "¬ b" := (negb b) (at level 10). @@ -53,12 +57,15 @@ Ltac bdestruct X := Ltac bdestructΩ X := bdestruct X; simpl; try lia. +<<<<<<< HEAD Ltac bdestruct_all := repeat match goal with | |- context[?a bdestruct (a bdestruct (a <=? b) | |- context[?a =? ?b] => bdestruct (a =? b) end; try (exfalso; lia). +======= +>>>>>>> Heisenberg-Foundations/main (* Distribute functions over lists *) @@ -222,6 +229,7 @@ Definition maybe {A} (o : option A) (default : A) : A := end. +<<<<<<< HEAD (* Why are we defining this from scratch??? *) Fixpoint inb (a : nat) (ls : list nat) : bool := match ls with @@ -319,6 +327,8 @@ Proof. rewrite IHoffset1. reflexivity. Qed. +======= +>>>>>>> Heisenberg-Foundations/main (************************************) (* Helpful, general purpose tactics *) @@ -406,3 +416,105 @@ Ltac unify_pows_two := | [ |- context[ (?a + (?b + ?c))%nat ]] => rewrite plus_assoc | [ |- (2^?x = 2^?y)%nat ] => apply pow_components; try lia end. +<<<<<<< HEAD +======= + + + +(* general subset to be used in Heisenberg.v *) +Definition subset_gen {X : Type} (l1 l2 : list X) := + forall (x : X), In x l1 -> In x l2. + + +(* an alternate version of subset *) +Fixpoint subset_gen' {X : Type} (l1 l2 : list X) := + match l1 with + | [] => True + | (l :: l1') => In l l2 /\ subset_gen' l1' l2 + end. + + +Lemma subset_is_subset' : forall (X : Type) (l1 l2 : list X), + subset_gen' l1 l2 <-> subset_gen l1 l2. +Proof. intros X l1 l2. split. + - induction l1 as [| l]. + * easy. + * simpl. intros [H1 H2]. + unfold subset_gen'. intros x. simpl. intros [H3 | H4]. + + rewrite H3 in H1. apply H1. + + apply IHl1 in H2. unfold subset_gen' in H2. + apply H2. apply H4. + - induction l1 as [| l]. + * easy. + * unfold subset_gen'. intros H. + simpl. split. + + apply H. simpl. left. reflexivity. + + apply IHl1. unfold subset_gen'. + intros x H'. apply H. simpl. + right. apply H'. +Qed. + + + +Infix "⊆" := subset_gen (at level 30, no associativity). + + +Lemma subset_cons : forall (X : Type) (l1 l2 : list X) (x : X), + l1 ⊆ l2 -> l1 ⊆ (x :: l2). +Proof. intros X l1 l2 x. + intros H. + intros x0 H0. + simpl; right. + apply H; apply H0. +Qed. + + +Lemma subset_concat_l : forall (X : Type) (l1 l2 : list X), + l1 ⊆ (l1 ++ l2). +Proof. intros X l1 l2. + intros x H. + apply in_or_app. + left; apply H. +Qed. + + +Lemma subset_concat_r : forall (X : Type) (l1 l2 : list X), + l1 ⊆ (l2 ++ l1). +Proof. intros X l1 l2. + intros x H. + apply in_or_app. + right; apply H. +Qed. + + +Corollary subset_self : forall (X : Type) (l1 : list X), + l1 ⊆ l1. +Proof. intros X l1. assert (H: l1 ⊆ (l1 ++ [])). { apply subset_concat_l. } + rewrite <- app_nil_end in H. apply H. +Qed. + + +Lemma subsets_add : forall (X : Type) (l1 l2 l3 : list X), + l1 ⊆ l3 -> l2 ⊆ l3 -> (l1 ++ l2) ⊆ l3. +Proof. intros X l1 l2 l3. + intros H1 H2 x H. + apply in_app_or in H. + destruct H as [Hl1 | Hl2]. + - apply H1; apply Hl1. + - apply H2; apply Hl2. +Qed. + + +Lemma subset_trans : forall (X : Type) (l1 l2 l3 : list X), + l1 ⊆ l2 -> l2 ⊆ l3 -> l1 ⊆ l3. +Proof. intros X l1 l2 l3. + intros H1 H2. + intros x H. + apply H1 in H; apply H2 in H. + apply H. +Qed. + + + +Hint Resolve subset_concat_l subset_concat_r subset_self subsets_add subset_trans : sub_db. +>>>>>>> Heisenberg-Foundations/main diff --git a/Programs.v b/Programs.v new file mode 100644 index 0000000..fe28bbe --- /dev/null +++ b/Programs.v @@ -0,0 +1,291 @@ +Require Export Types. + +(* Programs *) + +(* Can also use sequence and parallel in place of nats, ala QBricks *) +Inductive prog := +| H' (n : nat) +| S' (n : nat) +| T' (n : nat) +| CNOT (n1 n2 : nat) +| seq (p1 p2 : prog). + +Infix ";" := seq (at level 51, right associativity). + +(** Basic Typing judgements *) + +Parameter has_type : prog -> GType -> Prop. + +Notation "p :: T" := (has_type p T). + +Axiom HTypes : H' 0 :: (X → Z) ∩ (Z → X). +Axiom STypes : S' 0 :: (X → Y) ∩ (Z → Z). +Axiom CNOTTypes : CNOT 0 1 :: (X ⊗ I → X ⊗ X) ∩ (I ⊗ X → I ⊗ X) ∩ + (Z ⊗ I → Z ⊗ I) ∩ (I ⊗ Z → Z ⊗ Z). + +(* T only takes Z → Z *) +Axiom TTypes : T' 0 :: (Z → Z). + + + +Axiom SeqTypes : forall g1 g2 A B C, + g1 :: A → B -> + g2 :: B → C -> + g1 ; g2 :: A → C. + +Axiom seq_assoc : forall p1 p2 p3 A, + p1 ; (p2 ; p3) :: A <-> (p1 ; p2) ; p3 :: A. + +(* Note that this doesn't restrict # of qubits referenced by p. *) +Axiom TypesI : forall p, p :: I → I. +Axiom TypesI2 : forall p, p :: I ⊗ I → I ⊗ I. +Hint Resolve TypesI TypesI2 : base_types_db. + +(** Structural rules *) + +(* Subtyping rules *) +Axiom cap_elim_l : forall g A B, g :: A ∩ B -> g :: A. +Axiom cap_elim_r : forall g A B, g :: A ∩ B -> g :: B. +Axiom cap_intro : forall g A B, g :: A -> g :: B -> g :: A ∩ B. +Axiom cap_arrow : forall g A B C, + g :: (A → B) ∩ (A → C) -> + g :: A → (B ∩ C). + +Axiom arrow_sub : forall g A A' B B', + (forall l, l :: A' -> l :: A) -> + (forall r, r :: B -> r :: B') -> + g :: A → B -> + g :: A' → B'. + +Hint Resolve cap_elim_l cap_elim_r cap_intro cap_arrow arrow_sub : subtype_db. + +Lemma cap_elim : forall g A B, g :: A ∩ B -> g :: A /\ g :: B. +Proof. eauto with subtype_db. Qed. + +Lemma cap_arrow_distributes : forall g A A' B B', + g :: (A → A') ∩ (B → B') -> + g :: (A ∩ B) → (A' ∩ B'). +Proof. + intros; apply cap_arrow. + apply cap_intro; eauto with subtype_db. +Qed. + +Lemma cap_arrow_distributes' : forall g A A' B B', + g :: (A → A') ∩ (B → B') -> + g :: (A ∩ B) → (A' ∩ B'). +intros. + apply cap_elim in H as [TA TB]. + apply cap_arrow. + apply cap_intro. + - apply arrow_sub with (A := A) (B := A'); trivial. intros l. apply cap_elim_l. + - apply arrow_sub with (A := B) (B := B'); trivial. intros l. apply cap_elim_r. +Qed. + +(* Full explicit proof *) +Lemma cap_arrow_distributes'' : forall g A A' B B', + g :: (A → A') ∩ (B → B') -> + g :: (A ∩ B) → (A' ∩ B'). +Proof. + intros. + apply cap_arrow. + apply cap_intro. + - eapply arrow_sub; intros. + + eapply cap_elim_l. apply H0. + + apply H0. + + eapply cap_elim_l. apply H. + - eapply arrow_sub; intros. + + eapply cap_elim_r. apply H0. + + apply H0. + + eapply cap_elim_r. apply H. +Qed. + +(** Typing Rules for Tensors *) + +Notation s := Datatypes.S. + +Axiom tensor_base : forall g E A A', + Singleton A -> + g 0 :: (A → A') -> + g 0 :: A ⊗ E → A' ⊗ E. + +Axiom tensor_inc : forall g n E A A', + Singleton E -> + g n :: (A → A') -> + g (s n) :: E ⊗ A → E ⊗ A'. + +Axiom tensor_base2 : forall g E A A' B B', + Singleton A -> + Singleton B -> + g 0 1 :: (A ⊗ B → A' ⊗ B') -> + g 0 1 :: (A ⊗ B ⊗ E → A' ⊗ B' ⊗ E). + +Axiom tensor_base2_inv : forall g E A A' B B', + Singleton A -> + Singleton B -> + g 0 1 :: (B ⊗ A → B' ⊗ A') -> + g 1 0 :: (A ⊗ B ⊗ E → A' ⊗ B' ⊗ E). + +Axiom tensor_inc2 : forall (g : nat -> nat -> prog) m n E A A' B B', + Singleton E -> + g m n :: (A ⊗ B → A' ⊗ B') -> + g (s m) (s n) :: E ⊗ A ⊗ B → E ⊗ A' ⊗ B'. + +Axiom tensor_inc_l : forall (g : nat -> nat -> prog) m E A A' B B', + Singleton A -> + Singleton E -> + g m 0 :: (A ⊗ B → A' ⊗ B') -> + g (s m) 0 :: A ⊗ E ⊗ B → A' ⊗ E ⊗ B'. + +Axiom tensor_inc_r : forall (g : nat -> nat -> prog) n E A A' B B', + Singleton A -> + Singleton E -> + g 0 n :: (A ⊗ B → A' ⊗ B') -> + g 0 (s n) :: A ⊗ E ⊗ B → A' ⊗ E ⊗ B'. + +(* For flipping CNOTs. Could have CNOT specific rule. *) +Axiom tensor2_comm : forall (g : nat -> nat -> prog) A A' B B', + Singleton A -> + Singleton B -> + g 0 1 :: A ⊗ B → A' ⊗ B' -> + g 1 0 :: B ⊗ A → B' ⊗ A'. + + + + +(** Arrow rules *) + +(* Does this need restrictions? + If we had g :: X → iX then we could get + g :: I → -I which makes negation meaningless + (and leads to a contradiction if I ∩ -I = ⊥. +*) + +Axiom arrow_mul : forall p A A' B B', + p :: A → A' -> + p :: B → B' -> + p :: A * B → A' * B'. + +Axiom arrow_i : forall p A A', + p :: A → A' -> + p :: i A → i A'. + +Axiom arrow_neg : forall p A A', + p :: A → A' -> + p :: -A → -A'. + +Hint Resolve HTypes STypes TTypes CNOTTypes : base_types_db. +Hint Resolve cap_elim_l cap_elim_r : base_types_db. + +Hint Resolve HTypes STypes TTypes CNOTTypes : typing_db. +Hint Resolve cap_intro cap_elim_l cap_elim_r : typing_db. +Hint Resolve SeqTypes : typing_db. + +Lemma eq_arrow_r : forall g A B B', + g :: A → B -> + B = B' -> + g :: A → B'. +Proof. intros; subst; easy. Qed. + + +(* Tactics *) + +Ltac is_I A := + match A with + | I => idtac + end. + +Ltac is_prog1 A := + match A with + | H' => idtac + | S' => idtac + | T' => idtac + end. + +Ltac is_prog2 A := + match A with + | CNOT => idtac + end. + +(* Reduces to sequence of H, S and CNOT *) +Ltac type_check_base := + repeat apply cap_intro; + repeat eapply SeqTypes; (* will automatically unfold compound progs *) + repeat match goal with + | |- Singleton _ => auto 50 with sing_db + | |- ?g :: ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :: - ?A → ?B => apply arrow_neg + | |- ?g :: i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :: ?A * ?B → _ => apply arrow_mul + | |- ?g :: (?A * ?B) ⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :: I ⊗ (?A * ?B) → _ => rewrite decompose_tensor_mult_r + | |- ?g (S _) (S _) :: ?T => apply tensor_inc2 + | |- ?g 0 (S (S _)) :: ?T => apply tensor_inc_r + | |- ?g (S (S _)) 0 :: ?T => apply tensor_inc_l + | |- ?g 1 0 :: ?T => apply tensor_base2_inv + | |- ?g 0 1 :: ?T => apply tensor_base2 + | |- ?g 1 0 :: ?T => apply tensor2_comm + | |- ?g (S _) :: ?T => is_prog1 g; apply tensor_inc + | |- ?g 0 :: ?T => is_prog1 g; apply tensor_base + | |- ?g :: ?A ⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with sing_db) + | |- ?g :: ?A → ?B => tryif is_evar A then fail else + solve [eauto with base_types_db] + | |- ?B = ?B' => tryif has_evar B then fail else + (repeat rewrite mul_tensor_dist); + (repeat normalize_mul); + (repeat rewrite <- i_tensor_dist_l); + (repeat rewrite <- neg_tensor_dist_l); + autorewrite with mul_db; + try reflexivity + end. + + + +Definition CZ m n : prog := H' n ; CNOT m n ; H' n. +Definition SWAP m n : prog := CNOT m n; CNOT n m; CNOT m n. + + +Lemma CZTypes : CZ 0 1 :: (X ⊗ I → X ⊗ Z) ∩ (I ⊗ X → Z ⊗ X) ∩ + (Z ⊗ I → Z ⊗ I) ∩ (I ⊗ Z → I ⊗ Z). +Proof. type_check_base. Qed. + +Hint Resolve CZTypes : base_types_db. + + + +Definition bell00 : prog := H' 2; CNOT 2 3. + +Definition encode : prog := CZ 0 2; CNOT 1 2. + +Definition decode : prog := CNOT 2 3; H' 2. + +Definition superdense := bell00 ; encode; decode. + +Lemma superdenseTypesQPL : superdense :: (Z ⊗ Z ⊗ Z ⊗ Z → I ⊗ I ⊗ Z ⊗ Z). +Proof. repeat eapply SeqTypes. + apply tensor_inc. + auto 50 with sing_db. + apply tensor_inc. + auto 50 with sing_db. + apply tensor_base. + auto 50 with sing_db. + solve [eauto with base_types_db]. + apply tensor_inc2. + auto 50 with sing_db. + apply tensor_inc2. + auto 50 with sing_db. + match goal with + | |- ?g :: ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + end. + match goal with + | |- ?g :: ?A ⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with sing_db) + end. + match goal with + | |- ?g :: ?A * ?B → _ => apply arrow_mul + end. + + + + diff --git a/Quantum.v b/Quantum.v index 2675282..2fc1688 100644 --- a/Quantum.v +++ b/Quantum.v @@ -1,12 +1,23 @@ +<<<<<<< HEAD Require Import Psatz. +======= +Require Import Psatz. +>>>>>>> Heisenberg-Foundations/main Require Import Reals. Require Export Matrix. +<<<<<<< HEAD (* TODO: Add S and T gates, split this into multiple files including one for gates. *) (* Using our (complex, unbounded) matrices, their complex numbers *) +======= +(* Using our (complex, unbounded) matrices, their complex numbers *) + + + +>>>>>>> Heisenberg-Foundations/main (*******************************************) (** * Quantum basis states *) (*******************************************) @@ -136,6 +147,7 @@ Definition σz : Matrix 2 2 := | 1, 1 => -C1 | _, _ => C0 end. +<<<<<<< HEAD Definition sqrtx : Matrix 2 2 := fun x y => match x, y with @@ -154,6 +166,9 @@ Proof. autorewrite with trig_db C_db; try lca. Qed. +======= + +>>>>>>> Heisenberg-Foundations/main Definition control {n : nat} (A : Matrix n n) : Matrix (2*n) (2*n) := fun x y => if (x >>>>>> Heisenberg-Foundations/main Lemma Rx_rotation : forall θ, rotation θ (3*PI/2) (PI/2) = x_rotation θ. Proof. intros. @@ -387,12 +405,15 @@ Qed. (* Lemmas *) +<<<<<<< HEAD Lemma sqrtx_decompose: sqrtx = hadamard × phase_shift (PI/2) × hadamard. Proof. solve_matrix. all: rewrite Cexp_PI2; group_radicals; lca. Qed. +======= +>>>>>>> Heisenberg-Foundations/main (* Additional tactics for ∣0⟩, ∣1⟩, cnot and σx. *) Lemma Mmult00 : ⟨0∣ × ∣0⟩ = I 1. Proof. solve_matrix. Qed. @@ -558,6 +579,18 @@ Lemma WF_qubit0 : WF_Matrix ∣0⟩. Proof. show_wf. Qed. Lemma WF_qubit1 : WF_Matrix ∣1⟩. Proof. show_wf. Qed. Lemma WF_braqubit0 : WF_Matrix ∣0⟩⟨0∣. Proof. show_wf. Qed. Lemma WF_braqubit1 : WF_Matrix ∣1⟩⟨1∣. Proof. show_wf. Qed. +<<<<<<< HEAD +======= + +Lemma WF_bra : forall (x : nat), WF_Matrix (bra x). +Proof. intros x. unfold bra. destruct (x =? 0). show_wf. show_wf. +Qed. + +Lemma WF_ket : forall (x : nat), WF_Matrix (ket x). +Proof. intros x. unfold ket. destruct (x =? 0). show_wf. show_wf. +Qed. + +>>>>>>> Heisenberg-Foundations/main Lemma WF_bool_to_ket : forall b, WF_Matrix (bool_to_ket b). Proof. destruct b; show_wf. Qed. Lemma WF_bool_to_matrix : forall b, WF_Matrix (bool_to_matrix b). @@ -565,11 +598,14 @@ Proof. destruct b; show_wf. Qed. Lemma WF_bool_to_matrix' : forall b, WF_Matrix (bool_to_matrix' b). Proof. destruct b; show_wf. Qed. +<<<<<<< HEAD Lemma WF_ket : forall n, WF_Matrix (ket n). Proof. destruct n; simpl; show_wf. Qed. Lemma WF_bra : forall n, WF_Matrix (bra n). Proof. destruct n; simpl; show_wf. Qed. +======= +>>>>>>> Heisenberg-Foundations/main Lemma WF_bools_to_matrix : forall l, @WF_Matrix (2^(length l)) (2^(length l)) (bools_to_matrix l). Proof. @@ -580,9 +616,15 @@ Proof. apply IHl. Qed. +<<<<<<< HEAD Hint Resolve WF_bra0 WF_bra1 WF_qubit0 WF_qubit1 WF_braqubit0 WF_braqubit1 : wf_db. Hint Resolve WF_bool_to_ket WF_bool_to_matrix WF_bool_to_matrix' : wf_db. Hint Resolve WF_ket WF_bra WF_bools_to_matrix : wf_db. +======= +Hint Resolve WF_bra0 WF_bra1 WF_qubit0 WF_qubit1 WF_bra WF_ket WF_braqubit0 WF_braqubit1 : wf_db. +Hint Resolve WF_bool_to_ket WF_bool_to_matrix WF_bool_to_matrix' : wf_db. +Hint Resolve WF_bools_to_matrix : wf_db. +>>>>>>> Heisenberg-Foundations/main Lemma WF_hadamard : WF_Matrix hadamard. Proof. show_wf. Qed. Lemma WF_σx : WF_Matrix σx. Proof. show_wf. Qed. @@ -766,7 +808,13 @@ Proof. intros. rewrite <- Rx_rotation. apply rotation_unitary. Qed. Lemma y_rotation_unitary : forall θ, @WF_Unitary 2 (y_rotation θ). Proof. intros. rewrite <- Ry_rotation. apply rotation_unitary. Qed. +<<<<<<< HEAD Lemma control_unitary : forall n (A : Matrix n n), +======= +(* caused errors so commenting out for now: + + Lemma control_unitary : forall n (A : Matrix n n), +>>>>>>> Heisenberg-Foundations/main WF_Unitary A -> WF_Unitary (control A). Proof. intros n A H. @@ -775,11 +823,19 @@ Proof. unfold control, adjoint, Mmult, I. prep_matrix_equality. simpl. +<<<<<<< HEAD bdestructΩ (x =? y). - subst; simpl. rewrite Csum_sum. bdestructΩ (y >>>>>> Heisenberg-Foundations/main * rewrite Csum_0_bounded. Csimpl. rewrite (Csum_eq _ (fun x => A x (y - n)%nat ^* * A x (y - n)%nat)). ++ unfold control, adjoint, Mmult, I in U. @@ -788,6 +844,7 @@ Proof. eapply (equal_f) in U. rewrite U. rewrite Nat.eqb_refl. simpl. +<<<<<<< HEAD bdestructΩ (y - n >>>>>> Heisenberg-Foundations/main rewrite andb_false_r. bdestructΩ (n <=? x). simpl. lca. @@ -805,7 +873,11 @@ Proof. ++ lca. ++ intros. rewrite andb_false_r. +<<<<<<< HEAD bdestructΩ (n + x >>>>>> Heisenberg-Foundations/main simpl. lca. ++ exists y. @@ -816,7 +888,11 @@ Proof. bdestructΩ (y >>>>>> Heisenberg-Foundations/main repeat rewrite andb_false_r. lca. + rewrite 2 Csum_0_bounded; [lca| |]. @@ -892,7 +968,11 @@ Proof. rewrite andb_false_r. rewrite (WF _ (y-n)%nat) by (right; lia). destruct ((n <=? z) && (n <=? y)); lca. +<<<<<<< HEAD Qed. +======= +Qed. *) +>>>>>>> Heisenberg-Foundations/main Lemma transpose_unitary : forall n (A : Matrix n n), WF_Unitary A -> WF_Unitary (A†). Proof. @@ -902,11 +982,19 @@ Proof. + destruct H; auto with wf_db. + unfold WF_Unitary in *. rewrite adjoint_involutive. +<<<<<<< HEAD destruct H as [_ H]. apply Minv_left in H as [_ S]. (* NB: admitted lemma *) assumption. Qed. +======= + destruct H as [H H0]. + apply Minv_left in H0 as [_ S]; auto with wf_db. +Qed. + + +>>>>>>> Heisenberg-Foundations/main Lemma cnot_unitary : WF_Unitary cnot. Proof. split. @@ -1223,12 +1311,20 @@ Inductive Mixed_State {n} : Matrix n n -> Prop := | Pure_S : forall ρ, Pure_State ρ -> Mixed_State ρ | Mix_S : forall (p : R) ρ1 ρ2, 0 < p < 1 -> Mixed_State ρ1 -> Mixed_State ρ2 -> Mixed_State (p .* ρ1 .+ (1-p)%R .* ρ2). +<<<<<<< HEAD +======= + +>>>>>>> Heisenberg-Foundations/main Lemma WF_Pure : forall {n} (ρ : Density n), Pure_State ρ -> WF_Matrix ρ. Proof. intros. destruct H as [φ [[WFφ IP1] Eρ]]. rewrite Eρ. auto with wf_db. Qed. Hint Resolve WF_Pure : wf_db. +<<<<<<< HEAD Lemma WF_Mixed : forall {n} (ρ : Density n), Mixed_State ρ -> WF_Matrix ρ. +======= +Lemma WF_Mixed : forall {n} (ρ : Density n), Mixed_State ρ -> WF_Matrix ρ. +>>>>>>> Heisenberg-Foundations/main Proof. induction 1; auto with wf_db. Qed. Hint Resolve WF_Mixed : wf_db. @@ -1243,8 +1339,16 @@ Proof. exists (I 1). split. split. auto with wf_db. solve_matrix. solve_matrix. Lemma pure_dim1 : forall (ρ : Square 1), Pure_State ρ -> ρ = I 1. Proof. +<<<<<<< HEAD intros ρ [φ [[WFφ IP1] Eρ]]. apply Minv_flip in IP1. +======= + intros. + assert (H' := H). + apply WF_Pure in H'. + destruct H as [φ [[WFφ IP1] Eρ]]. + apply Minv_flip in IP1; auto with wf_db. +>>>>>>> Heisenberg-Foundations/main rewrite Eρ; easy. Qed. @@ -1388,17 +1492,41 @@ Proof. + apply pure_dim1; trivial. + rewrite IHMixed_State1, IHMixed_State2. prep_matrix_equality. +<<<<<<< HEAD lca. Qed. +======= + lca. +Qed. +>>>>>>> Heisenberg-Foundations/main (* Useful to be able to normalize vectors *) Definition norm {n} (ψ : Vector n) : R := sqrt (fst ((ψ† × ψ) O O)). +<<<<<<< HEAD Definition normalize {n} (ψ : Vector n) := / (norm ψ) .* ψ. +======= + + +Lemma norm_real : forall {n} (v : Vector n), snd ((v† × v) 0%nat 0%nat) = 0%R. +Proof. intros. unfold Mmult, adjoint. + rewrite Csum_snd_0. easy. + intros. rewrite Cmult_comm. + rewrite Cmult_conj_real. + reflexivity. +Qed. + + + +Definition normalize {n} (ψ : Vector n) := + / (norm ψ) .* ψ. + + +>>>>>>> Heisenberg-Foundations/main Lemma inner_product_ge_0 : forall {d} (ψ : Vector d), 0 <= fst ((ψ† × ψ) O O). Proof. @@ -1412,6 +1540,10 @@ Proof. apply Rmult_le_pos; apply Cmod_ge_0. Qed. +<<<<<<< HEAD +======= + +>>>>>>> Heisenberg-Foundations/main Lemma norm_scale : forall {n} c (v : Vector n), norm (c .* v) = ((Cmod c) * norm v)%R. Proof. intros n c v. @@ -1430,6 +1562,68 @@ Proof. lra. Qed. +<<<<<<< HEAD +======= + +Lemma div_real : forall (c : C), + snd c = 0 -> snd (/ c) = 0. +Proof. intros. + unfold Cinv. + simpl. + rewrite H. lra. +Qed. + + +Lemma Cmod_real : forall (c : C), + fst c >= 0 -> snd c = 0 -> Cmod c = fst c. +Proof. intros. + unfold Cmod. + rewrite H0. + simpl. + autorewrite with R_db. + apply sqrt_square. + lra. +Qed. + + +Lemma normalized_norm_1 : forall {n} (v : Vector n), + norm v <> 0 -> norm (normalize v) = 1. +Proof. intros. + unfold normalize. + distribute_scale. + rewrite norm_scale. + rewrite Cmod_real. + simpl. + autorewrite with R_db. + rewrite Rmult_comm. + rewrite Rinv_mult_distr; try easy. + rewrite <- Rmult_comm. + rewrite <- Rmult_assoc. + rewrite Rinv_r; try easy. + autorewrite with R_db. + reflexivity. + unfold Cinv. + simpl. + autorewrite with R_db. + rewrite Rinv_mult_distr; try easy. + rewrite <- Rmult_assoc. + rewrite Rinv_r; try easy. + autorewrite with R_db. + assert (H' : norm v >= 0). + { assert (H'' : 0 <= norm v). + { apply sqrt_pos. } + lra. } + destruct H' as [H0 | H0]. + left. + assert (H1 : 0 < norm v). { lra. } + apply Rinv_0_lt_compat in H1. + lra. easy. + apply div_real. + easy. +Qed. + + +>>>>>>> Heisenberg-Foundations/main (** Density matrices and superoperators **) Definition Superoperator m n := Density m -> Density n. @@ -1641,6 +1835,7 @@ Proof. simpl. rewrite Mmult_assoc. repeat rewrite Mmult_assoc. +<<<<<<< HEAD rewrite (kron_assoc q0 q1) by auto with wf_db. Qsimpl. replace 4%nat with (2*2)%nat by reflexivity. repeat rewrite kron_assoc by auto with wf_db. @@ -1650,6 +1845,18 @@ Proof. rewrite <- kron_assoc by auto with wf_db. Qsimpl. repeat rewrite <- kron_assoc by auto with wf_db. reflexivity. +======= + rewrite (kron_assoc q0 q1). Qsimpl. + replace 4%nat with (2*2)%nat by reflexivity. + repeat rewrite kron_assoc. + restore_dims. + rewrite <- (kron_assoc q0 q2). Qsimpl. + rewrite (kron_assoc q2). Qsimpl. + rewrite <- kron_assoc. Qsimpl. + repeat rewrite <- kron_assoc. + reflexivity. + all : auto with wf_db. +>>>>>>> Heisenberg-Foundations/main Qed. Lemma swap_two_base : swap_two 2 1 0 = swap. @@ -1695,16 +1902,29 @@ Proof. intros q0 q1 q2 q3 WF0 WF1 WF2 WF3. unfold move_to_0, move_to_0_aux. repeat rewrite Mmult_assoc. +<<<<<<< HEAD rewrite (kron_assoc q0 q1) by auto with wf_db. +======= + rewrite (kron_assoc q0 q1). +>>>>>>> Heisenberg-Foundations/main simpl. restore_dims. replace 4%nat with (2*2)%nat by reflexivity. Qsimpl. +<<<<<<< HEAD rewrite <- kron_assoc by auto with wf_db. restore_dims. repeat rewrite (kron_assoc _ q1) by auto with wf_db. Qsimpl. reflexivity. +======= + rewrite <- kron_assoc. + restore_dims. + repeat rewrite (kron_assoc _ q1). + Qsimpl. + reflexivity. + all : auto with wf_db. +>>>>>>> Heisenberg-Foundations/main Qed. (* *) diff --git a/README.md b/README.md index 8d9530e..0c912a1 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,4 @@ +<<<<<<< HEAD # QWIRE This is a Coq implementation of the QWIRE quantum programming language, described in the following papers by Jennifer Paykin, Robert Rand, Dong-Ho Lee and Steve Zdancewic: @@ -67,3 +68,7 @@ Files in this repository [7]: https://arxiv.org/abs/1707.03429 [8]: https://github.com/inQWIRE/LinearTypingContexts [9]: https://github.com/cpitclaudel/company-coq +======= +# Heisenberg-Foundations +The basics of the Heisenberg representation of quantum computing +>>>>>>> Heisenberg-Foundations/main diff --git a/RealAux.v b/RealAux.v index ddcf937..03d91ac 100644 --- a/RealAux.v +++ b/RealAux.v @@ -1,10 +1,18 @@ Require Export Reals. +<<<<<<< HEAD +======= + +>>>>>>> Heisenberg-Foundations/main Require Import Psatz. (******************************************) (** Relevant lemmas from Rcomplements.v. **) (******************************************) +<<<<<<< HEAD +======= + +>>>>>>> Heisenberg-Foundations/main Open Scope R_scope. Lemma Rle_minus_l : forall a b c,(a - c <= b <-> a <= b + c). Proof. intros. lra. Qed. diff --git a/Types.v b/Types.v new file mode 100644 index 0000000..6cc4e45 --- /dev/null +++ b/Types.v @@ -0,0 +1,3310 @@ +Require Import Psatz. +Require Import Reals. + + +Require Export Complex. +Require Export Matrix. +Require Export Quantum. +Require Export Eigenvectors. +Require Export Heisenberg. +Require Import Setoid. + + +(************************) +(* Defining coeficients *) +(************************) + + +Inductive Coef := +| p_1 +| p_i +| n_1 +| n_i. + +Definition cNeg (c : Coef) : Coef := + match c with + | p_1 => n_1 + | n_1 => p_1 + | p_i => n_i + | n_i => p_i + end. + +Lemma cNeg_inv : forall (c : Coef), cNeg (cNeg c) = c. +Proof. destruct c; easy. +Qed. + + +Definition cMul (c1 c2 : Coef) : Coef := + match (c1, c2) with + | (p_1, _) => c2 + | (_, p_1) => c1 + | (n_1, _) => cNeg c2 + | (_, n_1) => cNeg c1 + | (p_i, p_i) => n_1 + | (n_i, n_i) => n_1 + | (p_i, n_i) => p_1 + | (n_i, p_i) => p_1 + end. + +Fixpoint cBigMul (cs : list Coef) : Coef := + match cs with + | nil => p_1 + | c :: cs' => cMul c (cBigMul cs') + end. + + + +Infix "*" := cMul (at level 40, left associativity) : heisenberg_scope. + + +Lemma cMul_comm : forall (c1 c2 : Coef), c1 * c2 = c2 * c1. +Proof. intros. + destruct c1; + destruct c2; + easy. +Qed. + +Lemma cMul_assoc : forall (c1 c2 c3 : Coef), (c1 * c2) * c3 = c1 * (c2 * c3). +Proof. intros. + destruct c1; + destruct c2; + destruct c3; + easy. +Qed. + + +Lemma cBigMul_app : forall (l1 l2 : list Coef), + (cBigMul l1) * (cBigMul l2) = cBigMul (l1 ++ l2). +Proof. induction l1 as [| h]; try easy. + intros. simpl. + rewrite cMul_assoc, IHl1; easy. +Qed. + + + +Definition translate_coef (c : Coef) : C := + match c with + | p_1 => C1 + | p_i => Ci + | n_1 => -C1 + | n_i => -Ci + end. + +Lemma translate_coef_cMul : forall (c1 c2 : Coef), + translate_coef (c1 * c2) = ((translate_coef c1) * (translate_coef c2))%C. +Proof. intros. + destruct c1; + destruct c2; + unfold translate_coef; + unfold cMul; + unfold cNeg; + try lca. +Qed. + +Lemma translate_coef_nonzero : forall (c : Coef), translate_coef c <> C0. +Proof. destruct c; simpl; + try (apply C0_fst_neq; simpl; lra); + try (apply C0_snd_neq; simpl; lra). +Qed. + +(**********************) +(* Defining the types *) +(**********************) + +(* this is the lowest level, only Pauli gates are defined *) +Inductive Pauli := +| gI +| gX +| gY +| gZ. + +Definition translate_P (g : Pauli) : Square 2 := + match g with + | gI => I 2 + | gX => σx + | gY => σy + | gZ => σz + end. + + +Lemma WF_Matrix_Pauli : forall (g : Pauli), WF_Matrix (translate_P g). +Proof. intros. + destruct g; simpl; auto with wf_db. +Qed. + +Hint Resolve WF_Matrix_Pauli : wf_db. + +(* Here we define a gMul to give Coef followed by a gMul to give the actual type *) +(* this allows for an easy zip in gMulT *) + +Definition gMul_Coef (g1 g2 : Pauli) : Coef := + match g1, g2 with + | gI, _ => p_1 + | _, gI => p_1 + | gX, gX => p_1 + | gY, gY => p_1 + | gZ, gZ => p_1 + | gX, gY => p_i + | gY, gX => n_i + | gX, gZ => n_i + | gZ, gX => p_i + | gY, gZ => p_i + | gZ, gY => n_i + end. + +Definition gMul_base (g1 g2 : Pauli) : Pauli := + match g1, g2 with + | gI, _ => g2 + | _, gI => g1 + | gX, gX => gI + | gY, gY => gI + | gZ, gZ => gI + | gX, gY => gZ + | gY, gX => gZ + | gX, gZ => gY + | gZ, gX => gY + | gY, gZ => gX + | gZ, gY => gX + end. + + +(* scaling, multiplication, and tensoring done at this level *) +Definition TType (len : nat) := (Coef * (list Pauli))%type. + +(* we define an error TType for when things go wrong *) +Definition ErrT : TType 0 := (p_1, []). + + +Definition gMulT {n} (A B : TType n) : TType n := + match A with + | (c1, g1) => + match B with + | (c2, g2) => if length g1 =? length g2 + then (c1 * c2 * (cBigMul (zipWith gMul_Coef g1 g2)), + zipWith gMul_base g1 g2) + else ErrT + end + end. + + +Definition gTensorT {n m} (A : TType n) (B : TType m) : TType (n + m) := + match A with + | (c1, g1) => + match B with + | (c2, g2) => if (length g1 =? n) && (length g2 =? m) + then (c1 * c2, g1 ++ g2) + else ErrT + end + end. + +Definition gScaleT {n} (c : Coef) (A : TType n) : TType n := + match A with + | (c1, g1) => (c * c1, g1) + end. + + +Definition translate {n} (A : TType n) : Square (2^n) := + (translate_coef (fst A)) .* ⨂ (map translate_P (snd A)). + + + +Inductive vType (n : nat) : Type := + | G : TType n -> vType n + | Cap : vType n -> vType n -> vType n + | Arrow : vType n -> vType n -> vType n + | Err : vType n. + +Arguments G {n}. +Arguments Cap {n}. +Arguments Arrow {n}. +Arguments Err {n}. + + +(* you cannot multiply intersection or arrow types (for now) + so any of these options returns Err *) +Definition mul {n} (A B : vType n) : vType n := + match A with + | G a => + match B with + | G b => G (gMulT a b) + | _ => Err + end + | _ => Err + end. + +Definition tensor {n m} (A : vType n) (B : vType m) : vType (n + m) := + match A with + | G a => + match B with + | G b => G (gTensorT a b) + | _ => Err + end + | _ => Err + end. + +(* since scaling intersections makes sense, we allow this *) +Fixpoint scale {n} (c : Coef) (A : vType n) : vType n := + match A with + | G a => G (gScaleT c a) + | Cap g1 g2 => Cap (scale c g1) (scale c g2) + | _ => Err + end. + + +Definition i {n} (A : vType n) := scale p_i A. +Notation "- A" := (scale n_1 A). +Infix ".*" := mul (at level 40, left associativity). +Infix ".⊗" := tensor (at level 51, right associativity). + + + +Notation "A → B" := (Arrow A B) (at level 60, no associativity). +Notation "A ∩ B" := (Cap A B) (at level 60, no associativity). + +(******************************************************************************) +(* Defining different types of vTypes to ensure WF and Singleton translations *) +(******************************************************************************) + + +Inductive Sing_vt {n} : vType n -> Prop := +| G_svt : forall tt : TType n, Sing_vt (G tt). + +Inductive Cap_vt {n} : vType n -> Prop := +| G_cvt : forall tt : TType n, Cap_vt (G tt) +| Cap_cvt : forall T1 T2 : vType n, Cap_vt T1 -> Cap_vt T2 -> Cap_vt (Cap T1 T2). + +Lemma sing_implies_cap : forall {n} (T : vType n), + Sing_vt T -> Cap_vt T. +Proof. intros. inversion H; apply G_cvt. Qed. + +(* we also use a bool version of Cap_vt for matching *) +Fixpoint Cap_vt_bool {n} (A : vType n) : bool := + match A with + | G _ => true + | Cap v1 v2 => Cap_vt_bool v1 && Cap_vt_bool v2 + | _ => false + end. + +Lemma Cap_vt_conv : forall {n} (A : vType n), + Cap_vt A <-> Cap_vt_bool A = true. +Proof. intros. split. + + induction A as [| | |]; try easy. + - intros. + inversion H. + simpl; rewrite IHA1, IHA2; try easy. + + induction A as [| | |]; try easy. + - intros. + apply G_cvt. + - intros. + simpl in *. + apply andb_true_iff in H. + destruct H. + apply Cap_cvt; + try (apply IHA1); + try (apply IHA2); + assumption. +Qed. + +Inductive Sing_gt {n} : vType n -> Prop := +| Arrow_sgt : forall T1 T2 : vType n, Cap_vt T1 -> Cap_vt T2 -> Sing_gt (Arrow T1 T2). + +Inductive Cap_gt {n} : vType n -> Prop := +| Arrow_cgt : forall T : vType n, Sing_gt T -> Cap_gt T +| Cap_cgt : forall T1 T2 : vType n, Cap_gt T1 -> Cap_gt T2 -> Cap_gt (Cap T1 T2). + + +Fixpoint translate_vecType {n} (A : vType n) : vecType (2^n) := + match Cap_vt_bool A with + | false => [] + | true => + match A with + | G g => [translate g] + | Cap v1 v2 => translate_vecType v1 ++ translate_vecType v2 + | _ => [] + end + end. + + +Lemma singleton_sing_vt : forall {n m} (A : vType n), + Sing_vt A -> @Singleton m (translate_vecType A). +Proof. intros. destruct A; easy. +Qed. + + +Lemma sing_vt_simplify : forall {n} (A : vType n), + Sing_vt A -> (exists a, A = G a). +Proof. intros. destruct A; try easy. + - exists t. reflexivity. +Qed. + + +Definition I : vType 1 := G (p_1, [gI]). +Definition X : vType 1 := G (p_1, [gX]). +Definition Y : vType 1 := G (p_1, [gY]). +Definition Z : vType 1 := G (p_1, [gZ]). + +Lemma Itrans : translate_vecType I = I'. +Proof. simpl. + unfold translate; simpl. + rewrite Mscale_1_l, kron_1_r. + reflexivity. +Qed. + +Lemma Xtrans : translate_vecType X = X'. +Proof. simpl. + unfold translate; simpl. + rewrite Mscale_1_l, kron_1_r. + reflexivity. +Qed. + +Lemma Ytrans : translate_vecType Y = Y'. +Proof. simpl. + unfold translate; simpl. + rewrite Mscale_1_l, kron_1_r, Y_eq_iXZ. + distribute_scale. + reflexivity. +Qed. + +Lemma Ztrans : translate_vecType Z = Z'. +Proof. simpl. + unfold translate; simpl. + rewrite Mscale_1_l, kron_1_r. + reflexivity. +Qed. + +Lemma Y_is_iXZ : Y = (i (X .* Z)). +Proof. easy. Qed. + + +(***************) +(* Sing Lemmas *) +(***************) + +Lemma SI : Sing_vt I. Proof. easy. Qed. +Lemma SX : Sing_vt X. Proof. easy. Qed. +Lemma SZ : Sing_vt Z. Proof. easy. Qed. + +Lemma S_scale : forall {n} (A : vType n) (c : Coef), Sing_vt A -> (Sing_vt (scale c A)). +Proof. intros. destruct A; easy. Qed. + +Lemma S_neg : forall {n} (A : vType n), Sing_vt A -> Sing_vt (- A). +Proof. intros. destruct A; easy. Qed. + +Lemma S_i : forall {n} (A : vType n), Sing_vt A -> Sing_vt (i A). +Proof. intros. destruct A; easy. Qed. + +Lemma S_mul : forall {n} (A B : vType n), Sing_vt A -> Sing_vt B -> Sing_vt (A .* B). +Proof. intros. + destruct A; destruct B; easy. +Qed. + +Lemma S_tensor : forall {n m} (A : vType n) (B : vType m), Sing_vt A -> Sing_vt B -> Sing_vt (A .⊗ B). +Proof. intros. + destruct A; destruct B; easy. +Qed. + +Hint Resolve sing_implies_cap SI SX SZ S_scale S_neg S_i S_mul S_tensor : wfvt_db. + +Lemma SY : Sing_vt Y. +Proof. rewrite Y_is_iXZ. auto with wfvt_db. Qed. + + + + +(**************************) +(* Well Formedness Lemmas *) +(**************************) + + +Inductive WF_TType {len : nat} : TType len -> Prop := +| WF_tt : forall tt : TType len, length (snd tt) = len -> WF_TType tt. + +Inductive WF_vType {n} : vType n -> Prop := +| WF_G : forall tt : TType n, WF_TType tt -> WF_vType (G tt) +| WF_Cap : forall T1 T2 : vType n, WF_vType T1 -> WF_vType T2 -> WF_vType (Cap T1 T2) +| WF_Arrow : forall T1 T2 : vType n, WF_vType T1 -> WF_vType T2 -> WF_vType (Arrow T1 T2). + + +Lemma WF_I : WF_vType I. Proof. apply WF_G; easy. Qed. +Lemma WF_X : WF_vType X. Proof. apply WF_G; easy. Qed. +Lemma WF_Z : WF_vType Z. Proof. apply WF_G; easy. Qed. + +Lemma WF_scale : forall {n} (A : vType n) (c : Coef), + Sing_vt A -> WF_vType A -> + (WF_vType (scale c A)). +Proof. intros. + destruct A; try easy. + apply WF_G. + apply WF_tt. + inversion H0. + inversion H2. + destruct t; easy. +Qed. + +Lemma WF_mul : forall {n} (A B : vType n), + Sing_vt A -> Sing_vt B -> + WF_vType A -> WF_vType B -> + WF_vType (A .* B). +Proof. intros. + destruct A; + destruct B; try easy. + destruct t; + destruct t0. simpl. + inversion H1; inversion H2; inversion H4; inversion H6. + simpl in *; rewrite H7, H9; bdestruct_all. + apply WF_G; apply WF_tt. + simpl. + rewrite (zipWith_len_pres _ n); easy. +Qed. + + +Lemma WF_tensor : forall {n m} (A : vType n) (B : vType m), + Sing_vt A -> Sing_vt B -> + WF_vType A -> WF_vType B -> + WF_vType (A .⊗ B). +Proof. intros. + destruct A; + destruct B; try easy. + destruct t; + destruct t0. + simpl in *. + inversion H1; inversion H2; inversion H4; inversion H6. + simpl in *; rewrite H7, H9; bdestruct_all. + apply WF_G; apply WF_tt. + simpl. + rewrite app_length; + lia. +Qed. + + +Lemma WF_neg : forall {n} (A : vType n), + Sing_vt A -> WF_vType A -> WF_vType (- A). +Proof. intros. + destruct A; try easy. + inversion H0; inversion H2. + apply WF_G; apply WF_tt. + destruct t; easy. +Qed. + +Lemma WF_i : forall {n} (A : vType n), + Sing_vt A -> WF_vType A -> WF_vType (i A). +Proof. intros. + destruct A; try easy. + inversion H0; inversion H2. + apply WF_G; apply WF_tt. + destruct t; easy. +Qed. + + +Hint Resolve SI SX SZ WF_I WF_X WF_Z WF_mul WF_scale WF_tensor WF_neg WF_i : wfvt_db. + + +Lemma WF_Y : WF_vType Y. +Proof. rewrite Y_is_iXZ. auto with wfvt_db. Qed. + + +Lemma WF_Matrix_TType : forall {n} (A : TType n), WF_TType A -> WF_Matrix (translate A). +Proof. intros. destruct A. + unfold translate; simpl. + inversion H; simpl in *. + rewrite map_length, <- H0. + apply Matrix.WF_scale. + assert (H2 := (WF_big_kron _ _ (map translate_P l) (translate_P gI))). + rewrite map_length in *; apply H2. + intros. + rewrite map_nth. + apply WF_Matrix_Pauli. +Qed. + +Hint Resolve WF_Matrix_TType : wf_db. + +(*************) +(* WFS types *) +(*************) + +Inductive WFS_vType {n} : vType n -> Prop := +| WFS : forall T : vType n, Sing_vt T -> WF_vType T -> WFS_vType T. + + +Lemma WFS_I : WFS_vType I. Proof. apply WFS; auto with wfvt_db. Qed. +Lemma WFS_X : WFS_vType X. Proof. apply WFS; auto with wfvt_db. Qed. +Lemma WFS_Z : WFS_vType Z. Proof. apply WFS; auto with wfvt_db. Qed. + + +Lemma WFS_mul : forall {n} (A B : vType n), + WFS_vType A -> WFS_vType B -> + WFS_vType (A .* B). +Proof. intros n A B H H0. + inversion H; inversion H0. + apply WFS; auto with wfvt_db. +Qed. + + +Lemma WFS_tensor : forall {n m} (A : vType n) (B : vType m), + WFS_vType A -> WFS_vType B -> + WFS_vType (A .⊗ B). +Proof. intros n m A B H H0. + inversion H; inversion H0. + apply WFS; auto with wfvt_db. +Qed. + + +Lemma WFS_scale : forall {n} (A : vType n) (c : Coef), + WFS_vType A -> WFS_vType (scale c A). +Proof. intros n A c H. + inversion H. + apply WFS; auto with wfvt_db. +Qed. + +Lemma WFS_neg : forall {n} (A : vType n), + WFS_vType A -> WFS_vType (- A). +Proof. intros n A [H H0]. + apply WFS_scale; easy. +Qed. + +Lemma WFS_i : forall {n} (A : vType n), + WFS_vType A -> WFS_vType (i A). +Proof. intros n A H. + unfold i. + apply WFS_scale; easy. +Qed. + +Hint Resolve WFS_I WFS_X WFS_Z WFS_scale WFS_mul WFS_tensor WFS_neg WFS_i : wfvt_db. + +(******************) +(* unitary lemmas *) +(******************) + + +Lemma unit_Pauli : forall (p : Pauli), WF_Unitary (translate_P p). +Proof. intros. + destruct p; simpl; auto with unit_db. +Qed. + + +Lemma unit_TType : forall {n} (A : TType n), WF_TType A -> WF_Unitary (translate A). +Proof. intros. destruct A. + unfold translate; simpl. + inversion H; simpl in *. + rewrite map_length, <- H0. + apply unit_scale; try (destruct c; lca). + rewrite <- (map_length translate_P _). + apply (unit_big_kron 2 (map translate_P l)). + intros. + apply in_map_iff in H2. + do 2 (destruct H2). + rewrite <- H2. + apply unit_Pauli. +Qed. + +Lemma univ_TType : forall {n} (tt : TType n), + WF_TType tt -> uni_vecType ([translate tt]). +Proof. intros. + inversion H. + unfold uni_vecType. + intros A [H2 | F]; try easy. + rewrite <- H2. + apply unit_TType in H. + easy. +Qed. + +Lemma unit_vType : forall {n} (A : vType n), + WF_vType A -> uni_vecType (translate_vecType A). +Proof. intros. + induction A as [| | |]; try easy. + - simpl. apply (univ_TType t). + inversion H; + easy. + - simpl. + destruct (Cap_vt_bool A1 && Cap_vt_bool A2); try easy. + simpl in H. + unfold uni_vecType; intros. + apply in_app_or in H0. + inversion H. + destruct H0 as [H5| H6]. + + apply IHA1 in H3. + apply H3; easy. + + apply IHA2 in H4. + apply H4; easy. +Qed. + + +(******************************************************) +(* Showing translations preserves relevent properties *) +(******************************************************) + +(* we actually use this to prove translate_mult, so we prove it first *) +Lemma translate_kron : forall {n m} (g1 : TType n) (g2 : TType m), + length (snd g1) = n -> length (snd g2) = m -> + translate (gTensorT g1 g2) = (translate g1) ⊗ (translate g2). +Proof. intros. unfold translate. + destruct g1; destruct g2. + simpl in *. + do 3 (rewrite map_length). + rewrite H, H0 in *. + rewrite Mscale_kron_dist_r. + rewrite Mscale_kron_dist_l. + rewrite Mscale_assoc. + bdestruct_all; simpl. + rewrite translate_coef_cMul. + rewrite Cmult_comm. + rewrite map_app. + assert (H3 : forall (l : list Pauli) (i0 : nat), WF_Matrix (nth i0 (map translate_P l) Zero)). + { intros. + bdestruct (i0 length l2 = n -> + gMulT (c1, p1 :: l1) (c2, p2 :: l2) = + @gTensorT 1 n (gMul_Coef p1 p2, [gMul_base p1 p2]) (gMulT (c1, l1) (c2, l2)). +Proof. intros. simpl. + rewrite H, H0. + bdestruct (n =? n); try lia. + rewrite (zipWith_len_pres _ n); try easy. + bdestruct (n =? n); try lia. + rewrite zipWith_cons. + apply injective_projections; try easy. + simpl. + unfold zipWith. + rewrite <- (cMul_assoc (c1 * c2)), (cMul_comm (c1 * c2)). + replace (uncurry gMul_Coef (p1, p2)) with (gMul_Coef p1 p2) by easy. + rewrite cMul_assoc; easy. +Qed. + +Lemma translate_reduce : forall (n : nat) (c : Coef) (p : Pauli) (l : list Pauli), + length l = n -> + @translate (S n) (c, p :: l) = (translate_P p) ⊗ @translate n (c, l). +Proof. intros. + unfold translate. + simpl. + rewrite map_length. + replace (2^(length l) + (2^(length l) + 0))%nat with (2 * 2^(length l))%nat by lia. + rewrite <- Mscale_kron_dist_r. + rewrite H; easy. +Qed. + + +Lemma translate_Mmult : forall {n} (g1 g2 : TType n), + length (snd g1) = n -> length (snd g2) = n -> + translate (gMulT g1 g2) = (translate g1) × (translate g2). +Proof. intros. induction n as [| n']. + - destruct g1; destruct g2. + destruct l; destruct l0; try easy. + unfold translate. simpl. + distribute_scale. + rewrite Mmult_1_r; auto with wf_db. + rewrite <- translate_coef_cMul. + destruct c; destruct c0; try easy. + - destruct g1; destruct g2. + destruct l; destruct l0; try easy. + simpl in H; simpl in H0. + apply Nat.succ_inj in H. + apply Nat.succ_inj in H0. + rewrite gMulT_reduce; try easy. + replace (S n') with (1 + n')%nat by lia. + rewrite translate_kron; try easy. + rewrite IHn'; try easy. + rewrite (translate_reduce _ c), (translate_reduce _ c0); try easy. + restore_dims. + rewrite kron_mixed_product. + assert (H' : @translate 1 (gMul_Coef p p0, [gMul_base p p0]) = + translate_P p × translate_P p0). + { destruct p; destruct p0; simpl. + all : unfold translate; simpl. + all : lma'. } + rewrite H'; easy. + simpl. + rewrite H, H0; bdestruct_all. + simpl. + apply zipWith_len_pres; easy. +Qed. + + +Lemma translate_vecType_mMult : forall {n} (A B : vType n), + WFS_vType A -> WFS_vType B -> + translate_vecType (A .* B) = (translate_vecType A) *' (translate_vecType B). +Proof. intros n A B H H0. + inversion H; inversion H0. + destruct A; destruct B; try easy. + simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + rewrite translate_Mmult; try easy. +Qed. + + +Lemma translate_scale : forall {n} (A : TType n) (c : Coef), + translate (gScaleT c A) = Matrix.scale (translate_coef c) (translate A). +Proof. intros. + unfold translate. + destruct A. simpl. + rewrite translate_coef_cMul. + rewrite <- Mscale_assoc. + reflexivity. +Qed. + + + +Lemma Cap_vt_scale : forall {n} (A : vType n) (c : Coef), + Cap_vt_bool (scale c A) = Cap_vt_bool A. +Proof. intros. induction A as [| | |]; try easy. + simpl. rewrite IHA1, IHA2. + reflexivity. +Qed. + +Lemma translate_vecType_scale : forall {n} (A : vType n) (c : Coef), + translate_vecType (scale c A) = (translate_coef c) · (translate_vecType A). +Proof. intros. induction A; try easy. + - simpl. rewrite translate_scale. + reflexivity. + - simpl translate_vecType. + do 2 (rewrite Cap_vt_scale). + destruct (Cap_vt_bool A1 && Cap_vt_bool A2); try easy. + rewrite IHA1, IHA2. + rewrite concat_into_scale. + reflexivity. +Qed. + + + + + +(**************************) +(* Defining vector typing *) +(**************************) + + +(* we need this for now. should eventually rewrite defs to make proofs easier *) +Lemma fgt_conv : forall {n m} (A B : vecType n), [(A, B)] = @formGateType m A B. +Proof. easy. Qed. + +Lemma ite_conv : forall {X : Type} (x1 x2 : X), (if true && true then x1 else x2) = x1. +Proof. easy. Qed. + + +Definition vecPair (prg_len : nat) := (Vector (2^prg_len) * C)%type. + +Inductive vecHasType {prg_len : nat} : vecPair prg_len -> vType prg_len -> Prop := +| VHT : forall vp T, Cap_vt T -> pairHasType vp (translate_vecType T) -> + vecHasType vp T. + + +Notation "p ;' T" := (vecHasType p T) (at level 61, no associativity). + + + +Lemma cap_elim_l_vec : forall {n} (v : vecPair n) (A B : vType n), v ;' (A ∩ B) -> v ;' A. +Proof. intros. + inversion H; inversion H0. + apply VHT; try easy. + simpl translate_vecType in *. + apply Cap_vt_conv in H6; + apply Cap_vt_conv in H7. + rewrite H6, H7 in H1. + simpl in H1. + apply (Heisenberg.cap_elim_l_pair _ _ (translate_vecType B)). + assumption. +Qed. + + +Lemma cap_elim_r_vec : forall {n} (v : vecPair n) (A B : vType n), v ;' A ∩ B -> v ;' B. +Proof. intros. + inversion H; inversion H0. + apply VHT; try easy. + simpl translate_vecType in *. + apply Cap_vt_conv in H6; + apply Cap_vt_conv in H7. + rewrite H6, H7 in H1. + simpl in H1. + apply (Heisenberg.cap_elim_r_pair _ (translate_vecType A) _). + assumption. +Qed. + + +Hint Resolve cap_elim_l_vec cap_elim_r_vec : subtype_db. + + +(***************************************************************************) +(* proving some preliminary lemmas on the TType level before we prove their + counterparts on the vType level *) +(***************************************************************************) + + +Lemma gMulT_gTensorT_dist : forall {n m : nat} (t1 t2 : TType n) (t3 t4 : TType m), + WF_TType t1 -> WF_TType t2 -> WF_TType t3 -> WF_TType t4 -> + gMulT (gTensorT t1 t3) (gTensorT t2 t4) = gTensorT (gMulT t1 t2) (gMulT t3 t4). +Proof. intros. + destruct t1; destruct t2; destruct t3; destruct t4. + simpl gTensorT. + inversion H; inversion H0; inversion H1; inversion H2. + simpl in *. + rewrite H3, H5, H7, H9. + bdestruct_all. simpl. + rewrite (zipWith_len_pres _ n), (zipWith_len_pres _ m); try easy. + do 2 rewrite app_length. + rewrite H3, H5, H7, H9. + bdestruct_all. simpl. + apply injective_projections; simpl. + - rewrite (cMul_assoc (c * c0)). + rewrite (cMul_comm (cBigMul (zipWith gMul_Coef l l0))). + rewrite (cMul_assoc (c1 * c2)). + rewrite (cMul_comm (cBigMul (zipWith gMul_Coef l1 l2))). + rewrite cBigMul_app. + rewrite (zipWith_app_product _ n); try easy. + rewrite (cMul_assoc c), <- (cMul_assoc c1), (cMul_comm c1 c0). + repeat rewrite cMul_assoc; easy. + - rewrite (zipWith_app_product _ n); easy. +Qed. + + +Lemma gMulT_assoc : forall (n : nat) (t1 t2 t3 : TType n), + WF_TType t1 -> WF_TType t2 -> WF_TType t3 -> + gMulT (gMulT t1 t2) t3 = gMulT t1 (gMulT t2 t3). +Proof. induction n as [| n']. + - intros. + inversion H; inversion H0; inversion H1. + destruct t1; destruct t2; destruct t3. + destruct l; destruct l0; destruct l1; try easy. + destruct c; destruct c0; destruct c1; easy. + - intros. + inversion H; inversion H0; inversion H1. + destruct t1; destruct t2; destruct t3. + destruct l; destruct l0; destruct l1; try easy. + simpl in H2; simpl in H4; simpl in H6. + apply Nat.succ_inj in H2; + apply Nat.succ_inj in H4; + apply Nat.succ_inj in H6. + repeat rewrite gMulT_reduce; try easy. + assert (H8 : (c1, p1 :: l1) = @gTensorT 1 n' (p_1, [p1]) (c1, l1)). + { simpl. bdestruct_all. easy. } + assert (H9 : (c, p :: l) = @gTensorT 1 n' (p_1, [p]) (c, l)). + { simpl. bdestruct_all. easy. } + rewrite H8, H9. + do 2 replace (S n') with (1 + n')%nat by lia. + rewrite gMulT_gTensorT_dist, gMulT_gTensorT_dist; try easy. + rewrite IHn'; try easy. + assert (H10 : (@gMulT 1 (gMul_Coef p p0, [gMul_base p p0]) (p_1, [p1])) = + (@gMulT 1 (p_1, [p]) (gMul_Coef p0 p1, [gMul_base p0 p1]))). + { destruct p; destruct p0; destruct p1; easy. } + rewrite H10; easy. + all : simpl; bdestruct_all; apply WF_tt; simpl. + all : rewrite (zipWith_len_pres _ n'); easy. +Qed. + + +(* Multiplication laws *) + +Lemma mul_assoc : forall {n} (A B C : vType n), + WFS_vType A -> WFS_vType B -> WFS_vType C -> + A .* (B .* C) = A .* B .* C. +Proof. intros. + destruct A; destruct B; destruct C; try easy. + inversion H; inversion H0; inversion H1. + unfold mul. + inversion H3; inversion H6; inversion H9. + rewrite gMulT_assoc; easy. +Qed. + + +Lemma mul_I_l : forall (A : vType 1), WFS_vType A -> I .* A = A. +Proof. intros A H. + inversion H. + destruct A; try easy. + inversion H1; inversion H4. + destruct t. + do 2 (destruct l; try easy). + simpl. + destruct c; easy. +Qed. + +Lemma mul_I_r : forall (A : vType 1), WFS_vType A -> A .* I = A. +Proof. intros A H. + inversion H. + destruct A; try easy. + inversion H1; inversion H4. + destruct t. + do 2 (destruct l; try easy). + simpl. + destruct p; destruct c; easy. +Qed. + +Lemma Xsqr : X .* X = I. +Proof. easy. Qed. + +Lemma Zsqr : Z .* Z = I. +Proof. easy. Qed. + +Lemma ZmulX : Z .* X = - (X .* Z). +Proof. easy. Qed. + + +Lemma neg_inv : forall (n : nat) (A : vType n), WFS_vType A -> - - A = A. +Proof. intros n A H. + inversion H. + destruct A; try easy. + simpl. + unfold gScaleT. + destruct t; destruct c; easy. +Qed. + + +Lemma neg_dist_l : forall (n : nat) (A B : vType n), + WFS_vType A -> WFS_vType B -> + -A .* B = - (A .* B). +Proof. intros. + inversion H; inversion H0. + destruct A; destruct B; try easy. + destruct t; destruct t0; simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + simpl in *. + rewrite H11, H13. + bdestruct_all; try easy. + unfold gScaleT. + repeat rewrite cMul_assoc. + easy. +Qed. + + +Lemma neg_dist_r : forall (n : nat) (A B : vType n), + WFS_vType A -> WFS_vType B -> + A .* (-B) = - (A .* B). +Proof. intros. + inversion H; inversion H0. + destruct A; destruct B; try easy. + destruct t; destruct t0; simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + simpl in *. + rewrite H11, H13. + bdestruct_all; try easy. + unfold gScaleT. + rewrite <- cMul_assoc, (cMul_comm c). + repeat rewrite cMul_assoc. + easy. +Qed. + + +Lemma i_sqr : forall (n : nat) (A : vType n), i (i A) = -A. +Proof. intros. + induction A; try easy. + - destruct t. simpl. + destruct c; easy. + - simpl. unfold i in *. + simpl. + rewrite IHA1, IHA2. + reflexivity. +Qed. + +Lemma i_dist_l : forall (n : nat) (A B : vType n), + WFS_vType A -> WFS_vType B -> + i A .* B = i (A .* B). +Proof. intros. + inversion H; inversion H0. + destruct A; destruct B; try easy. + destruct t; destruct t0; simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + simpl in *. + bdestruct_all; try easy. + unfold gScaleT. + repeat rewrite cMul_assoc. + easy. +Qed. + + +Lemma i_dist_r : forall (n : nat) (A B : vType n), + WFS_vType A -> WFS_vType B -> + A .* i B = i (A .* B). +Proof. intros. + inversion H; inversion H0. + destruct A; destruct B; try easy. + destruct t; destruct t0; simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + simpl in *. + rewrite H11, H13. + bdestruct_all; try easy. + unfold gScaleT. + rewrite <- cMul_assoc, (cMul_comm c). + repeat rewrite cMul_assoc. + easy. +Qed. + + +Lemma i_neg_comm : forall (n : nat) (A : vType n), i (-A) = -i A. +Proof. intros. + induction A; try easy. + - destruct t. simpl. + destruct c; easy. + - simpl. unfold i in *. + simpl. + rewrite IHA1, IHA2. + reflexivity. +Qed. + + +(** ** Tensor Laws *) + +(* +Lemma tensor_assoc : forall {n m o : nat} (A : vType n) (B : vType m) (C : vType o), + eq_vType' (A .⊗ (B .⊗ C)) ((A .⊗ B) .⊗ C). +Proof. intros. unfold eq_vType'. + destruct A; destruct B; destruct C; try easy. + destruct t; destruct t0; destruct t1; simpl. + rewrite app_ass. + rewrite cMul_assoc. + reflexivity. +Qed. +*) + + +Lemma neg_tensor_dist_l : forall {n m} (A : vType n) (B : vType m), + WFS_vType A -> WFS_vType B -> + -A .⊗ B = - (A .⊗ B). +Proof. intros. + inversion H; inversion H0. + destruct A; destruct B; try easy. + destruct t; destruct t0; simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + bdestruct_all; try easy; simpl. + destruct c; destruct c0; easy. +Qed. + + +Lemma neg_tensor_dist_r : forall {n m} (A : vType n) (B : vType m), + WFS_vType A -> WFS_vType B -> + A .⊗ (-B) = - (A .⊗ B). +Proof. intros. + inversion H; inversion H0. + destruct A; destruct B; try easy. + destruct t; destruct t0; simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + bdestruct_all; try easy; simpl. + destruct c; destruct c0; easy. +Qed. + + +Lemma i_tensor_dist_l : forall {n m} (A : vType n) (B : vType m), + WFS_vType A -> WFS_vType B -> + i A .⊗ B = i (A .⊗ B). +Proof. intros. + inversion H; inversion H0. + destruct A; destruct B; try easy. + destruct t; destruct t0; simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + bdestruct_all; try easy; simpl. + destruct c; destruct c0; easy. +Qed. + + +Lemma i_tensor_dist_r : forall {n m} (A : vType n) (B : vType m), + WFS_vType A -> WFS_vType B -> + A .⊗ i B = i (A .⊗ B). +Proof. intros. + inversion H; inversion H0. + destruct A; destruct B; try easy. + destruct t; destruct t0; simpl. + inversion H2; inversion H5. + inversion H8; inversion H10. + bdestruct_all; try easy; simpl. + destruct c; destruct c0; easy. +Qed. + + + +(** ** Multiplication & Tensor Laws *) + +(* Appropriate restriction is that size A = size C and size B = size D, + but axiomatization doesn't allow for that calculation. *) +(* This should be generalizable to the other, assuming we're multiplying + valid types. *) +Lemma mul_tensor_dist : forall {n m} (A C : vType n) (B D : vType m), + WFS_vType A -> WFS_vType B -> WFS_vType C -> WFS_vType D -> + (A .⊗ B) .* (C .⊗ D) = (A .* C) .⊗ (B .* D). +Proof. intros. + destruct A; destruct B; destruct C; destruct D; try easy. + inversion H; inversion H0; inversion H1; inversion H2. + inversion H4; inversion H7; inversion H10; inversion H13. + inversion H16; inversion H18; inversion H20; inversion H22. + unfold mul, tensor. + rewrite gMulT_gTensorT_dist; easy. +Qed. + + + +Lemma decompose_tensor : forall (A B : vType 1), + WFS_vType A -> WFS_vType B -> + A .⊗ B = (A .⊗ I) .* (I .⊗ B). +Proof. + intros A B H H0. + rewrite mul_tensor_dist; auto with wfvt_db. + rewrite mul_I_r, mul_I_l; easy. +Qed. + + +Lemma decompose_tensor_mult_l : forall (A B : vType 1), + WFS_vType A -> WFS_vType B -> + (A .* B) .⊗ I = (A .⊗ I) .* (B .⊗ I). +Proof. + intros. + rewrite mul_tensor_dist; auto with wfvt_db. +Qed. + + +Lemma decompose_tensor_mult_r : forall (A B : vType 1), + WFS_vType A -> WFS_vType B -> + I .⊗ (A .* B) = (I .⊗ A) .* (I .⊗ B). +Proof. + intros. + rewrite mul_tensor_dist; auto with wfvt_db. +Qed. + + +(*********************) +(* defining programs *) +(*********************) + +Inductive prog := +| H' (n : nat) +| S' (n : nat) +| T' (n : nat) +| CNOT (n1 n2 : nat) +| seq (p1 p2 : prog). + +Infix ";;" := seq (at level 51, right associativity). + + +Fixpoint translate_prog (prg_len : nat) (p : prog) : Square (2^prg_len) := + match p with + | H' n => (prog_smpl_app prg_len hadamard n) + | S' n => (prog_smpl_app prg_len Phase n) + | T' n => (prog_smpl_app prg_len (phase_shift (PI / 4)) n) + | CNOT n1 n2 => (prog_ctrl_app prg_len σx n1 n2) + | seq p1 p2 => (translate_prog prg_len p1) ; (translate_prog prg_len p2) + end. + + +Lemma unit_prog : forall (prg_len : nat) (p : prog), + WF_Unitary (translate_prog prg_len p). +Proof. intros. induction p as [| | | |]; + try (apply unit_prog_smpl_app; auto with unit_db); + try (apply unit_prog_ctrl_app; auto with unit_db). + simpl. apply Mmult_unitary; easy. +Qed. + + +Inductive progHasSingType {prg_len : nat} : prog -> vType prg_len -> vType prg_len -> Prop := +| PHST : forall p T1 T2, Cap_vt T1 -> Cap_vt T2 -> + (translate_prog prg_len p) ::' [(translate_vecType T1, translate_vecType T2)] -> + progHasSingType p T1 T2. +(* should use two cons for PHT, one for arrow one for cap *) + +Inductive progHasType {prg_len : nat} : prog -> vType prg_len -> Prop := +| Arrow_pht : forall p T1 T2, progHasSingType p T1 T2 -> progHasType p (Arrow T1 T2) +| Cap_pht : forall p T1 T2, progHasType p T1 -> progHasType p T2 -> progHasType p (Cap T1 T2). + + + +Notation "p :' T" := (progHasType p T). + + + + +(********************) +(* Base type lemmas *) +(********************) + + +Lemma Hsimp : prog_smpl_app 1 hadamard 0 = hadamard. +Proof. unfold prog_smpl_app. + rewrite kron_1_r. + rewrite kron_1_l. + reflexivity. + auto with wf_db. +Qed. + +Lemma Ssimp : prog_smpl_app 1 Phase 0 = Phase. +Proof. unfold prog_smpl_app. + rewrite kron_1_r. + rewrite kron_1_l. + reflexivity. + auto with wf_db. +Qed. + + +Lemma Isimp : @translate 1 (p_1, [gI]) = Matrix.I 2. +Proof. unfold translate; simpl. + lma'. +Qed. + +Lemma Xsimp : @translate 1 (p_1, [gX]) = σx. +Proof. unfold translate; simpl. + lma'. +Qed. + +Lemma Zsimp : @translate 1 (p_1, [gZ]) = σz. +Proof. unfold translate; simpl. + lma'. +Qed. + +Lemma Ysimp : @translate 1 (p_1, [gY]) = σy. +Proof. unfold translate; simpl. + lma'. +Qed. + + +Lemma kron_simp : forall (g1 g2 : Pauli), + @translate 2 (p_1 * p_1, g1 :: [g2]) = (translate_P g1) ⊗ (translate_P g2). +Proof. intros. + unfold translate; simpl. + autorewrite with C_db. + rewrite Mscale_1_l. + rewrite kron_1_r. + reflexivity. +Qed. + + +Hint Rewrite Ssimp Hsimp Isimp Xsimp Zsimp Ysimp adj_ctrlX_is_cnot1 kron_simp : simp_db. + +Ltac solve_ground_type := repeat (apply Cap_pht); try apply Arrow_pht; + try apply PHST; try apply G_cvt; simpl; + autorewrite with simp_db; + repeat split; + repeat (apply sgt_implies_sgt'; try easy; + apply singleton_simplify2; + unfold translate; simpl; auto with id_db). + + +Lemma HTypes : H' 0 :' (X → Z) ∩ (Z → X). +Proof. solve_ground_type. Qed. + + +Lemma HTypes_not : ~ (H' 0 :' (X → X)). +Proof. solve_ground_type. unfold not. + intros. + inversion H; inversion H2. + simpl in H6. + destruct H6 as [H6 _]. + apply sgt'_implies_sgt in H6. + unfold singGateType in H6. + assert (H' : hadamard × σx = σx × hadamard). + { autorewrite with simp_db in H6. + apply H6. left; easy. left; easy. } + assert (H'' : forall (m1 m2 : Square 2), m1 = m2 -> m1 1%nat 0%nat = m2 1%nat 0%nat). + { intros. rewrite H10. reflexivity. } + apply H'' in H'. + unfold Mmult in H'. simpl in H'. + replace (C0 + C1 * (C1 / √ 2) + C0 * (C1 / √ 2)) with (C1 / √ 2) in H' by lca. + replace (C0 + C1 / √ 2 * C0 + Copp (C1 / √ 2) * C1) with (Copp (C1 / √ 2)) in H' by lca. + unfold Cdiv in H'. + rewrite Copp_mult_distr_l in H'. + assert (H10 : forall c1 c2 , (c1 = c2 -> c1 * √ 2 = c2 * √ 2)%C). + { intros. rewrite H10. easy. } + apply H10 in H'. + do 2 (rewrite <- Cmult_assoc in H'). + rewrite (Cinv_l (√ 2)) in H'. + do 2 (rewrite Cmult_1_r in H'). + assert (H11: forall {X} (p1 p2 : X * X), p1 = p2 -> fst p1 = fst p2). + { intros. rewrite H11. easy. } + apply H11 in H'. simpl in H'. + lra. + apply C0_fst_neq. simpl. + apply sqrt_neq_0_compat. + lra. + autorewrite with simp_db; auto with unit_db. + auto with sing_db. + simpl. + unfold translate; simpl. + rewrite Mscale_1_l, kron_1_r. + replace [σx] with X' by easy. + auto with univ_db. +Qed. + +Lemma STypes : S' 0 :' (X → Y) ∩ (Z → Z). +Proof. solve_ground_type. +Qed. + + +Lemma CNOTTypes : CNOT 0 1 :' (X .⊗ I → X .⊗ X) ∩ (I .⊗ X → I .⊗ X) ∩ + (Z .⊗ I → Z .⊗ I) ∩ (I .⊗ Z → Z .⊗ Z). +Proof. solve_ground_type. Qed. + + + +Notation CZ m n := (H' n ;; CNOT m n ;; H' n). + + + + +(*************************) +(* Proving typing lemmas *) +(*************************) + +Lemma SeqTypes : forall {n} (g1 g2 : prog) (A B C : vType n), + g1 :' A → B -> + g2 :' B → C -> + (g1 ;; g2) :' A → C. +Proof. intros. + inversion H; inversion H0. + apply Arrow_pht. + inversion H3; inversion H7. + apply PHST; try easy. + simpl translate_prog. + rewrite (@fgt_conv (2^n) _ _ _). + apply (Heisenberg.SeqTypes (translate_prog n g1) _ _ (translate_vecType B) _); + rewrite <- (@fgt_conv (2^n) _ _ _); try easy. +Qed. + + +Lemma seq_assoc : forall {n} (g1 g2 g3 : prog) (T : vType n), + g1 ;; (g2 ;; g3) :' T <-> (g1 ;; g2) ;; g3 :' T. +Proof. induction T as [| | |]; try easy. + - simpl. split. + all : intros; + inversion H; + apply Cap_pht; try apply IHT1; try apply IHT2; easy. + - split; intros; + inversion H; inversion H2; + apply Arrow_pht; apply PHST; + simpl translate_prog; + try apply Heisenberg.seq_assoc; + easy. +Qed. + + +(* Note that this doesn't restrict # of qubits referenced by p. *) +Lemma TypesI : forall (p : prog), p :' I → I. +Proof. intros. + apply Arrow_pht; apply PHST; auto with wfvt_db. + rewrite Itrans. + rewrite fgt_conv. + apply Heisenberg.TypesI1. + apply (unit_prog 1 p). +Qed. + + + +Lemma TypesI2 : forall (p : prog), p :' I .⊗ I → I .⊗ I. +Proof. intros. + apply Arrow_pht; apply PHST; auto with wfvt_db. + assert (H' : translate_vecType (I .⊗ I) = I' ⊗' I'). + { simpl; unfold translate; simpl. + rewrite Mscale_1_l, kron_1_r; easy. } + rewrite H'. + apply Heisenberg.TypesI2. + apply (unit_prog 2 p). +Qed. + + +Hint Resolve TypesI TypesI2 : base_types_db. + + +(** Structural rules *) + +(* Subtyping rules *) +Lemma cap_elim_l : forall {n} (g : prog) (A B : vType n), g :' A ∩ B -> g :' A. +Proof. intros. inversion H; easy. Qed. + +Lemma cap_elim_r : forall {n} (g : prog) (A B : vType n), g :' A ∩ B -> g :' B. +Proof. intros. inversion H; easy. Qed. + +Lemma cap_intro : forall {n} (g : prog) (A B : vType n), g :' A -> g :' B -> g :' A ∩ B. +Proof. intros. apply Cap_pht; easy. +Qed. + +Lemma cap_arrow : forall {n} (g : prog) (A B C : vType n), + g :' (A → B) ∩ (A → C) -> + g :' A → (B ∩ C). +Proof. intros. + inversion H; inversion H3; inversion H4. + inversion H7; inversion H11. + apply Arrow_pht. + apply PHST; try apply Cap_cvt; auto. + rewrite fgt_conv in *. + assert (H' : translate_vecType (Cap B C) = + (translate_vecType B) ++ (translate_vecType C)). + { simpl. + apply Cap_vt_conv in H14. + apply Cap_vt_conv in H20. + rewrite H14, H20; easy. } + rewrite H'. + apply Heisenberg.cap_arrow. + simpl in *. split; auto. + apply H15. +Qed. + + + +Lemma arrow_sub : forall {n} g (A A' B B' : vType n), + Cap_vt A' -> Cap_vt B' -> + (forall l, l ;' A' -> l ;' A) -> + (forall r, r ;' B -> r ;' B') -> + g :' A → B -> + g :' A' → B'. +Proof. intros. + apply Arrow_pht; apply PHST; auto. + inversion H3; inversion H6. + apply (Heisenberg.arrow_sub _ (translate_vecType A) _ (translate_vecType B) _); try easy. + all : intros; apply VHT in H14; auto. + apply H1 in H14; inversion H14; easy. + apply H2 in H14; inversion H14; easy. +Qed. + + +Hint Resolve cap_elim_l cap_elim_r cap_intro cap_arrow arrow_sub : subtype_db. + +Lemma cap_elim : forall {n} g (A B : vType n), g :' A ∩ B -> g :' A /\ g :' B. +Proof. eauto with subtype_db. Qed. + + +Lemma input_cap_l : forall {n} g (A A' B : vType n), + Cap_vt A' -> g :' A → B -> g :' (A ∩ A') → B. +Proof. intros. + inversion H0; inversion H3. + apply (arrow_sub g A (A ∩ A') B B); auto. + apply Cap_cvt; auto. + intros. + eauto with subtype_db. +Qed. + +Lemma input_cap_r : forall {n} g (A A' B : vType n), + Cap_vt A' -> g :' A → B -> g :' (A' ∩ A) → B. +Proof. intros. + inversion H0; inversion H3. + apply (arrow_sub g A (A' ∩ A) B B); auto. + apply Cap_cvt; auto. + intros. + eauto with subtype_db. +Qed. + +(* Full explicit proof (due to changes to arrow_sub) *) +Lemma cap_arrow_distributes : forall {n} g (A A' B B' : vType n), + g :' (A → A') ∩ (B → B') -> + g :' (A ∩ B) → (A' ∩ B'). +Proof. intros. + inversion H. + apply cap_arrow; apply Cap_pht. + - inversion H4; inversion H7. + apply input_cap_l; easy. + - inversion H3; inversion H7. + apply input_cap_r; easy. +Qed. + + + + + +(***************************************************) +(* Prelim lemmas for tensoring in the next section *) +(***************************************************) + + +Local Open Scope nat_scope. + +Notation s := Datatypes.S. + + +Definition smpl_prog_H (p : nat -> prog) : Prop := + (forall (n : nat), p n = H' n). +Definition smpl_prog_S (p : nat -> prog) : Prop := + (forall (n : nat), p n = S' n). + +Definition smpl_prog_T (p : nat -> prog) : Prop := + (forall (n : nat), p n = T' n). + +Definition smpl_prog (p : nat -> prog) : Prop := + smpl_prog_H p \/ smpl_prog_S p \/ smpl_prog_T p. + + +Definition ctrl_prog (p : prog) : Prop := + match p with + | CNOT _ _ => True + | _ => False + end. + + +Lemma smpl_prog_H_ver : smpl_prog H'. Proof. left. easy. Qed. +Lemma smpl_prog_S_ver : smpl_prog S'. Proof. right. left. easy. Qed. +Lemma smpl_prog_T_ver : smpl_prog T'. Proof. right. right. easy. Qed. + +Hint Resolve smpl_prog_H_ver smpl_prog_S_ver smpl_prog_T_ver : wfvt_db. + + +Lemma prog_smpl_inc_reduce : forall (p : nat -> prog) (prg_len bit : nat), + smpl_prog p -> bit < prg_len -> + translate_prog prg_len (p bit) = + (Matrix.I (2^bit)) ⊗ translate_prog 1 (p 0) ⊗ (Matrix.I (2^(prg_len - bit - 1))). +Proof. intros. + destruct H. + - do 2 (rewrite H). + simpl. + unfold prog_smpl_app. + bdestruct_all. + rewrite Nat.sub_0_r, Nat.sub_diag, + Nat.pow_0_r, kron_1_l, kron_1_r; auto with wf_db. + - destruct H. + + do 2 (rewrite H). + simpl. + unfold prog_smpl_app. + bdestruct_all. + rewrite Nat.sub_0_r, Nat.sub_diag, + Nat.pow_0_r, kron_1_l, kron_1_r; auto with wf_db. + + do 2 (rewrite H). + simpl. + unfold prog_smpl_app. + bdestruct_all. + rewrite Nat.sub_0_r, Nat.sub_diag, + Nat.pow_0_r, kron_1_l, kron_1_r; auto with wf_db. +Qed. + + +Lemma prog_ctrl_reduce : forall (prg_len ctrl targ : nat), + translate_prog (s prg_len) (CNOT (s ctrl) (s targ)) = + (Matrix.I 2) ⊗ translate_prog prg_len (CNOT ctrl targ). +Proof. intros. + unfold translate_prog, prog_ctrl_app. + bdestruct_all; simpl. + all : try (rewrite id_kron, Nat.add_0_r, double_mult; easy). + - replace (2 ^ ctrl + (2 ^ ctrl + 0)) with (2 * 2^ctrl) by lia. + rewrite <- id_kron. + repeat rewrite kron_assoc; auto with wf_db. + repeat rewrite Nat.add_0_r. repeat rewrite double_mult. + replace 2 with (2^1) by easy. + repeat rewrite <- Nat.pow_add_r. + replace (ctrl + ((1 + (targ - ctrl)) + (prg_len - targ - 1))) with prg_len by lia; + easy. + - replace (2 ^ targ + (2 ^ targ + 0)) with (2 * 2^targ) by lia. + rewrite <- id_kron. + repeat rewrite kron_assoc; auto with wf_db. + repeat rewrite Nat.add_0_r. repeat rewrite double_mult. + replace 2 with (2^1) by easy. + repeat rewrite <- Nat.pow_add_r. + replace (targ + (((ctrl - targ) + 1) + (prg_len - ctrl - 1))) with prg_len by lia; + easy. +Qed. + + + +Lemma WF_helper : forall (l : list Pauli) (i : nat), + WF_Matrix (nth i (map translate_P l) Zero). +Proof. intros. + destruct (nth_in_or_default i0 (map translate_P l) Zero). + - apply in_map_iff in i1. + destruct i1 as [x [H H0]]. + rewrite <- H. + apply WF_Matrix_Pauli. + - rewrite e. easy. +Qed. + +Lemma WF_helper2 : forall {bit} (l : list Pauli), + length l = bit -> + @WF_Matrix (2^ bit) (2^ bit) (⨂ map translate_P l). +Proof. intros; subst. + assert (H' := (WF_big_kron _ _ (map translate_P l) Zero)). + rewrite map_length in H'. + apply H'. + intros; apply WF_helper. +Qed. + +Hint Resolve WF_helper WF_helper2 : wf_db. + +(* TODO : remove since in Matrix.v *) +Lemma kron_simplify : forall (n m o p : nat) (a b : Matrix n m) (c d : Matrix o p), + a = b -> c = d -> a ⊗ c = b ⊗ d. +Proof. Admitted. + + +Lemma tensor_smpl_ground : forall (prg_len bit : nat) (p : nat -> prog) + (l : list Pauli) (a : Pauli) (c1 c2 : Coef), + smpl_prog p -> bit < prg_len -> + prg_len = length l -> + (p 0) :' @G 1 (p_1, [nth bit l gI]) → @G 1 (c2, [a]) -> + (p bit) :' @G prg_len (c1, l) → @G prg_len (cMul c1 c2, switch l a bit). +Proof. intros. + inversion H2; inversion H5; subst. + apply Arrow_pht; apply PHST; try apply G_cvt. + simpl in *. destruct H9; split; try easy. + apply sgt_implies_sgt'; try easy. + apply sgt'_implies_sgt in H1; try easy. + unfold singGateType in *; intros; simpl in *. + destruct H4; destruct H6; try easy. + rewrite <- H4, <- H6. + unfold translate in *; simpl in *. + rewrite (nth_inc bit l gI); auto. + repeat rewrite map_app. + rewrite <- (nth_inc bit l gI); auto. + rewrite switch_inc; auto. + repeat rewrite map_app. + repeat rewrite big_kron_app; try (intros; apply WF_helper). + repeat rewrite app_length. + repeat rewrite map_length. + rewrite firstn_length_le, skipn_length; try lia. + do 4 rewrite Nat.pow_add_r. + do 2 rewrite <- Mscale_kron_dist_r, <- Mscale_kron_dist_l. + rewrite prog_smpl_inc_reduce; auto. + rewrite kron_assoc; auto with wf_db. + replace (length l - bit - 1) with (length l - s bit) by lia. + repeat rewrite (kron_mixed_product' _ _ _ _ _ _ _ _ (2 ^ (length l))); + try (simpl; lia). + apply kron_simplify. + rewrite Mmult_1_l, Mmult_1_r; try easy; try apply WF_helper2. + all : try (apply firstn_length_le; lia). + repeat rewrite (kron_mixed_product' _ _ _ _ _ _ _ _ ((2^1) * (2^(length l - s bit)))); + try (simpl; lia). + apply kron_simplify. simpl. + rewrite Mscale_mult_dist_r, (H1 _ (translate_coef c2 .* (translate_P a ⊗ Matrix.I 1))%M). + rewrite Mscale_mult_dist_l, Mscale_assoc, <- translate_coef_cMul, Mscale_mult_dist_l; easy. + all : try (left; try rewrite Mscale_1_l; easy). + assert (H' := (WF_big_kron _ _ (map translate_P (skipn (s bit) l)))). + rewrite map_length, skipn_length in H'; try lia. + rewrite Mmult_1_l, Mmult_1_r; try easy. + all : try apply (H' Zero); intros. + all : try apply WF_helper. + all : try (simpl length; do 2 rewrite <- Nat.pow_add_r; apply pow_components; lia). + apply unit_prog. + all : try (rewrite <- map_app; apply WF_helper). + rewrite <- (Nat.pow_1_r 2); apply unit_prog. + simpl; split; apply (@univ_TType 1); apply WF_tt; easy. +Qed. + + + + +Lemma tensor_ctrl_zero : forall (l : list Pauli) (prg_len targ : nat) + (a b : Pauli) (c1 c2 : Coef), + targ < prg_len -> 0 <> targ -> + prg_len = length l -> + (CNOT 0 1) :' @G 2 (p_1, (nth 0 l gI) :: [nth targ l gI]) → @G 2 (c2, a :: [b]) -> + (CNOT 0 targ) :' @G prg_len (c1, l) → + @G prg_len (cMul c1 c2, switch (switch l a 0) b targ). +Proof. intros. destruct targ; try easy. + inversion H2; inversion H5; subst. + apply Arrow_pht; apply PHST; try apply G_cvt. + destruct l; try easy. + simpl in *. destruct H9; split; try easy. + apply sgt_implies_sgt'; try easy. + apply sgt'_implies_sgt in H1; try easy. + unfold singGateType in *; intros; simpl in *. + destruct H4; destruct H6; try easy. + rewrite <- H4, <- H6. + unfold translate in *; simpl in *. + bdestruct (targ ctrl <> 0 -> + prg_len = length l -> + (CNOT 0 1) :' @G 2 (p_1, (nth ctrl l gI) :: [nth 0 l gI]) → @G 2 (c2, a :: [b]) -> + (CNOT ctrl 0) :' @G prg_len (c1, l) → + @G prg_len (cMul c1 c2, switch (switch l a ctrl) b 0). +Proof. intros. destruct ctrl; try easy. + inversion H2; inversion H5; subst. + apply Arrow_pht; apply PHST; try apply G_cvt. + destruct l; try easy. + simpl in *. destruct H9; split; try easy. + apply sgt_implies_sgt'; try easy. + apply sgt'_implies_sgt in H1; try easy. + unfold singGateType in *; intros; simpl in *. + destruct H4; destruct H6; try easy. + rewrite <- H4, <- H6. + unfold translate in *; simpl in *. + bdestruct (ctrl prg_len = length l2 -> + (CNOT ctrl targ) :' @G prg_len (c1, l1) → @G prg_len (c2, l2) -> + (CNOT (s ctrl) (s targ)) :' @G (s prg_len) (c1, a :: l1) → @G (s prg_len) (c2, a :: l2). +Proof. intros. + inversion H1; inversion H4; subst. + apply Arrow_pht; apply PHST; try apply G_cvt. + rewrite prog_ctrl_reduce. + simpl in *. destruct H8; split; try easy. + apply sgt_implies_sgt'; try easy. + apply sgt'_implies_sgt in H; try easy. + unfold singGateType in *; intros; simpl in *. + destruct H3; destruct H5; try easy. + rewrite <- H3, <- H5. + unfold translate in *; simpl in *. + do 2 rewrite map_length, Nat.add_0_r, double_mult, <- Mscale_kron_dist_r. + rewrite <- H0. + do 2 rewrite kron_mixed_product. + rewrite (H _ (translate_coef c2 .* (⨂ map translate_P l2))%M); + try (left; easy). + rewrite Mmult_1_r, Mmult_1_l; auto with wf_db. + apply unit_prog_ctrl_app; auto with unit_db. + simpl; split; apply (@univ_TType (length l1)); apply WF_tt; easy. +Qed. + + +Lemma tensor_ctrl_ground : forall (l : list Pauli) (prg_len ctrl targ : nat) + (a b : Pauli) (c1 c2 : Coef), + ctrl < prg_len -> targ < prg_len -> ctrl <> targ -> + prg_len = length l -> + (CNOT 0 1) :' @G 2 (p_1, (nth ctrl l gI) :: [nth targ l gI]) → @G 2 (c2, a :: [b]) -> + (CNOT ctrl targ) :' @G prg_len (c1, l) → + @G prg_len (cMul c1 c2, switch (switch l a ctrl) b targ). +Proof. induction l. + - intros; subst; simpl in *; lia. + - intros. + destruct ctrl; try (apply tensor_ctrl_zero; auto). + destruct targ; try (apply tensor_targ_zero; auto). + subst; simpl in *. + apply tensor_ctrl_reduce; auto. + do 2 rewrite switch_len; easy. + apply IHl; auto; lia. +Qed. + + +(****************) +(* tensor rules *) +(****************) + + +Definition nth_vType {n} (bit : nat) (A : vType n) : vType 1 := + match A with + | G g => G (p_1, [nth bit (snd g) gI]) + | _ => Err + end. + + +Definition switch_vType {n} (A : vType n) (a : vType 1) (bit : nat) : vType n := + match A with + | G g => + match a with + | G g0 => G (cMul (fst g) (fst g0), switch (snd g) (hd gI (snd g0)) bit) + | _ => Err + end + | _ => Err + end. + + + +Lemma WFS_nth_vType : forall {n} (A : vType n) (bit : nat), + WFS_vType A -> WFS_vType (nth_vType bit A). +Proof. intros. + inversion H; subst. + destruct A; try easy. + apply WFS. + apply G_svt. + apply WF_G; apply WF_tt. + easy. +Qed. + + +Lemma WFS_switch_vType : forall {n} (A : vType n) (a : vType 1) (bit : nat), + WFS_vType A -> WFS_vType a -> WFS_vType (switch_vType A a bit). +Proof. intros. + inversion H; inversion H0; subst. + destruct A; destruct a; try easy. + apply WFS. + apply G_svt. + apply WF_G; apply WF_tt. + simpl. rewrite switch_len. + inversion H2; inversion H6; + easy. +Qed. + + +Hint Resolve WFS_nth_vType WFS_switch_vType : wfvt_db. + + + +Lemma tensor_smpl : forall (prg_len bit : nat) (p : nat -> prog) + (A : vType prg_len) (a : vType 1), + WFS_vType a -> WFS_vType A -> + smpl_prog p -> bit < prg_len -> + (p 0) :' (nth_vType bit A) → a -> + (p bit) :' A → (switch_vType A a bit). +Proof. intros. + inversion H; inversion H0; subst. + inversion H5; inversion H8; subst; try easy. + destruct tt; destruct tt0; simpl. + inversion H6; inversion H10; subst. + apply tensor_smpl_ground; auto; simpl in *. + do 2 (destruct l; try easy). +Qed. + + + + +Lemma tensor_ctrl : forall (prg_len ctrl targ : nat) + (A : vType prg_len) (a b : vType 1), + WFS_vType A -> WFS_vType a -> WFS_vType b -> + ctrl < prg_len -> targ < prg_len -> ctrl <> targ -> + (CNOT 0 1) :' (nth_vType ctrl A) .⊗ (nth_vType targ A) → a .⊗ b -> + (CNOT ctrl targ) :' A → switch_vType (switch_vType A a ctrl) b targ. +Proof. intros. + inversion H; inversion H0; inversion H1; subst. + inversion H7; inversion H10; inversion H13; subst; try easy. + destruct tt; destruct tt0; destruct tt1; simpl. + inversion H8; inversion H14; inversion H16; subst. + rewrite cMul_assoc. + apply tensor_ctrl_ground; auto; simpl in *. + rewrite H17, H19 in H5; simpl in H5. + do 2 (destruct l0; destruct l1; try easy). +Qed. + + +(***************) +(* Arrow rules *) +(***************) + + +Lemma arrow_mul : forall {n} g (A A' B B' : vType n), + WFS_vType A -> WFS_vType A' -> + WFS_vType B -> WFS_vType B' -> + g :' A → A' -> + g :' B → B' -> + g :' A .* B → A' .* B'. +Proof. intros; simpl in *. + inversion H3; inversion H4; inversion H7; inversion H11; + inversion H; inversion H0; inversion H1; inversion H2; subst. + apply Arrow_pht; apply PHST; auto with wfvt_db. + destruct A; destruct A'; destruct B; destruct B'; try easy. + do 2 (rewrite translate_vecType_mMult; try easy). + rewrite fgt_conv. + apply Heisenberg.arrow_mul; + try (apply unit_prog); + try (apply unit_vType); try easy. +Qed. + + +Lemma mul_simp : forall (a b : Pauli), + @G 1 (gMul_Coef a b, [gMul_base a b]) = @G 1 (p_1, [a]) .* @G 1 (p_1, [b]). +Proof. intros. + simpl. + destruct a; destruct b; try easy. +Qed. + + +Lemma arrow_mul_1 : forall g (a a' b b' : Pauli), + g :' @G 1 (p_1, [a]) → @G 1 (p_1, [a']) -> + g :' @G 1 (p_1, [b]) → @G 1 (p_1, [b']) -> + g :' @G 1 (gMul_Coef a b, [gMul_base a b]) → @G 1 (gMul_Coef a' b', [gMul_base a' b']). +Proof. intros. + do 2 rewrite mul_simp. + apply arrow_mul; try easy; apply WFS; try apply G_svt. + all : apply WF_G; apply WF_tt; easy. +Qed. + + + +Lemma arrow_scale : forall {n} (p : prog) (A A' : vType n) (c : Coef), + p :' A → A' -> p :' (scale c A) → (scale c A'). +Proof. intros. + inversion H; inversion H2; subst. + apply Cap_vt_conv in H4; apply Cap_vt_conv in H5. + apply Arrow_pht; apply PHST; auto with wfvt_db. + all : try (apply Cap_vt_conv; rewrite Cap_vt_scale; easy). + rewrite fgt_conv in *. + do 2 (rewrite translate_vecType_scale). + apply Heisenberg.arrow_scale; try easy. + apply translate_coef_nonzero. +Qed. + + +Lemma arrow_i : forall {n} (p : prog) (A A' : vType n), + p :' A → A' -> + p :' i A → i A'. +Proof. intros; + apply arrow_scale; + assumption. +Qed. + + +Lemma arrow_neg : forall {n} (p : prog) (A A' : vType n), + p :' A → A' -> + p :' -A → -A'. +Proof. intros; + apply arrow_scale; + assumption. +Qed. + + + +Hint Resolve HTypes STypes TTypes CNOTTypes : base_types_db. +Hint Resolve cap_elim_l cap_elim_r : base_types_db. + +Hint Resolve HTypes STypes TTypes CNOTTypes : typing_db. +Hint Resolve cap_intro cap_elim_l cap_elim_r : typing_db. +Hint Resolve SeqTypes : typing_db. + + + +(* basically just eq_type_conv_output but with different order hypotheses *) +Lemma eq_arrow_r : forall {n} (g : prog) (A B B' : vType n), + g :' A → B -> + B = B' -> + g :' A → B'. +Proof. intros. subst; easy. Qed. + +(* Tactics *) + + +Ltac is_I A := + match A with + | I => idtac + end. + +Ltac is_prog1 A := + match A with + | H' _ => idtac + | S' _ => idtac + | T' _ => idtac + end. + +Ltac is_prog2 A := + match A with + | CNOT _ _ => idtac + end. + + + +Ltac expand_prog := match goal with + | |- ?p1 ;; ?p2 :' ?T => eapply SeqTypes + end. + +(* Reduces to sequence of H, S and CNOT *) + + +Ltac solve_smpl := apply tensor_smpl; + try (solve [eauto with base_types_db]); auto with wfvt_db. + + +Ltac solve_ctrl := apply tensor_ctrl; + try (solve [eauto with base_types_db]); auto with wfvt_db. + + +Lemma CZTypes : CZ 0 1 :' (X .⊗ I → X .⊗ Z) ∩ (I .⊗ X → Z .⊗ X) ∩ + (Z .⊗ I → Z .⊗ I) ∩ (I .⊗ Z → I .⊗ Z). +Proof. repeat apply cap_intro; + repeat expand_prog. + solve_smpl. + solve_ctrl. + eapply eq_arrow_r. + solve_smpl. + easy. + simpl. + + apply tensor_smpl; auto with wfvt_db. + 2 : solve [eauto with base_types_db]. + auto with wfvt_db. + solve [eauto with base_types_db]. + eapply eq_arrow_r. + apply tensor_smpl; auto with wfvt_db. + 2 : solve [eauto with base_types_db]. + auto with wfvt_db. + easy. + apply tensor_smpl; auto with wfvt_db. + 2 : solve [eauto with base_types_db]. + auto with wfvt_db. + + + + +apply + + + + + + rewrite (decompose_tensor) by (auto 50 with wfvt_db). + eapply eq_arrow_r. + apply arrow_mul. + + apply tensor_ctrl_base. + solve [eauto with base_types_db]. + +Qed. + + + +Ltac type_check_base := + repeat apply cap_intro; + repeat expand_prog; (* will automatically unfold compound progs *) + repeat match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- WFS_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A .⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => rewrite decompose_tensor_mult_r + | |- CNOT (s _) (s _) :' ?T => apply tensor_ctrl_inc + | |- CNOT 0 (s (s _)) :' ?T => apply tensor_ctrl_inc_r + | |- CNOT (s (s _)) 0 :' ?T => apply tensor_ctrl_inc_l + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_base_inv + | |- CNOT 0 1 :' ?T => apply tensor_ctrl_base + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_comm + | |- H' (s _) :' ?T => apply tensor_smpl_inc + | |- H' 0 :' ?T => apply tensor_smpl_base + | |- S' (s _) :' ?T => apply tensor_smpl_inc + | |- S' 0 :' ?T => apply tensor_smpl_base + | |- T' (s _) :' ?T => apply tensor_smpl_inc + | |- T' 0 :' ?T => apply 4tensor_smpl_base + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with wfvt_db) + | |- ?g :' ?A → ?B => tryif is_evar A then fail else + solve [eauto with base_types_db] + | |- ?A = ?B => tryif is_evar B then fail else + (repeat rewrite mul_tensor_dist); + (repeat normalize_mul); + (repeat rewrite <- i_tensor_dist_l); + (repeat rewrite <- neg_tensor_dist_l); + autorewrite with mul_db; + try reflexivity + end; auto with wfvt_db; try easy. + + + +Opaque progHasType. + + +Lemma CZTypes : CZ 0 1 :' (X .⊗ I → X .⊗ Z) ∩ (I .⊗ X → Z .⊗ X) ∩ + (Z .⊗ I → Z .⊗ I) ∩ (I .⊗ Z → I .⊗ Z). +Proof. type_check_base. +Qed. + + + +Notation bell00 := ((H' 2);; (CNOT 2 3)). + +Notation encode := ((CZ 0 2);; (CNOT 1 2)). + +Notation decode := ((CNOT 2 3);; (H' 2)). + +Notation superdense := (bell00;; encode;; decode). + + + +Lemma superdenseTypesQPL : superdense :' (Z .⊗ Z .⊗ Z .⊗ Z → I .⊗ I .⊗ Z .⊗ Z). +Proof. repeat expand_prog. + type_check_base. + type_check_base. + type_check_base. + simpl. compute. + rewrite mul_tensor_dist; auto with wfvt_db. + type_check_base. + type_check_base. + type_check_base. + type_check_base. + type_check_base. +Qed. + + + rewrite mul_tensor_dist; auto with wfvt_db. + + + +match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- WFS_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A .⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => rewrite decompose_tensor_mult_r + | |- CNOT (s _) (s _) :' ?T => apply tensor_ctrl_inc + | |- CNOT 0 (s (s _)) :' ?T => apply tensor_ctrl_inc_r + | |- CNOT (s (s _)) 0 :' ?T => apply tensor_ctrl_inc_l + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_base_inv + | |- CNOT 0 1 :' ?T => apply tensor_ctrl_base + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_comm + | |- H' (s _) :' ?T => apply tensor_smpl_inc + | |- H' 0 :' ?T => apply tensor_smpl_base + | |- S' (s _) :' ?T => apply tensor_smpl_inc + | |- S' 0 :' ?T => apply tensor_smpl_base + | |- T' (s _) :' ?T => apply tensor_smpl_inc + | |- T' 0 :' ?T => apply tensor_smpl_base + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with wfvt_db) + | |- ?g :' ?A → ?B => tryif is_evar A then fail else + solve [eauto with base_types_db] + | |- ?A = ?B => tryif is_evar B then fail else + (repeat rewrite mul_tensor_dist); + (repeat normalize_mul); + (repeat rewrite <- i_tensor_dist_l); + (repeat rewrite <- neg_tensor_dist_l); + autorewrite with mul_db; + try reflexivity + end. +6 : match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- WFS_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A .⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => rewrite decompose_tensor_mult_r + | |- CNOT (s _) (s _) :' ?T => apply tensor_ctrl_inc + | |- CNOT 0 (s (s _)) :' ?T => apply tensor_ctrl_inc_r + | |- CNOT (s (s _)) 0 :' ?T => apply tensor_ctrl_inc_l + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_base_inv + | |- CNOT 0 1 :' ?T => apply tensor_ctrl_base + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_comm + | |- H' (s _) :' ?T => apply tensor_smpl_inc + | |- H' 0 :' ?T => apply tensor_smpl_base + | |- S' (s _) :' ?T => apply tensor_smpl_inc + | |- S' 0 :' ?T => apply tensor_smpl_base + | |- T' (s _) :' ?T => apply tensor_smpl_inc + | |- T' 0 :' ?T => apply tensor_smpl_base + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with wfvt_db) + | |- ?g :' ?A → ?B => tryif is_evar A then fail else + solve [eauto with base_types_db] + | |- ?A = ?B => tryif is_evar B then fail else + (repeat rewrite mul_tensor_dist); + (repeat normalize_mul); + (repeat rewrite <- i_tensor_dist_l); + (repeat rewrite <- neg_tensor_dist_l); + autorewrite with mul_db; + try reflexivity + end. + + +6 : match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- WFS_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A .⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => rewrite decompose_tensor_mult_r + | |- CNOT (s _) (s _) :' ?T => apply tensor_ctrl_inc + | |- CNOT 0 (s (s _)) :' ?T => apply tensor_ctrl_inc_r + | |- CNOT (s (s _)) 0 :' ?T => apply tensor_ctrl_inc_l + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_base_inv + | |- CNOT 0 1 :' ?T => apply tensor_ctrl_base + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_comm + | |- H' (s _) :' ?T => apply tensor_smpl_inc + | |- H' 0 :' ?T => apply tensor_smpl_base + | |- S' (s _) :' ?T => apply tensor_smpl_inc + | |- S' 0 :' ?T => apply tensor_smpl_base + | |- T' (s _) :' ?T => apply tensor_smpl_inc + | |- T' 0 :' ?T => apply tensor_smpl_base + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with wfvt_db) + | |- ?g :' ?A → ?B => tryif is_evar A then fail else + solve [eauto with base_types_db] + | |- ?A = ?B => tryif is_evar B then fail else + (repeat rewrite mul_tensor_dist); + (repeat normalize_mul); + (repeat rewrite <- i_tensor_dist_l); + (repeat rewrite <- neg_tensor_dist_l); + autorewrite with mul_db; + try reflexivity + end. + type_check_base. easy. + 6 : { rewrite mul_tensor_dist; auto with wfvt_db. + rewrite mul_tensor_dist; auto with wfvt_db. +match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- WFS_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A .⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => rewrite decompose_tensor_mult_r + | |- CNOT (s _) (s _) :' ?T => apply tensor_ctrl_inc + | |- CNOT 0 (s (s _)) :' ?T => apply tensor_ctrl_inc_r + | |- CNOT (s (s _)) 0 :' ?T => apply tensor_ctrl_inc_l + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_base_inv + | |- CNOT 0 1 :' ?T => apply tensor_ctrl_base + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_comm + | |- H' (s _) :' ?T => apply tensor_smpl_inc + | |- H' 0 :' ?T => apply tensor_smpl_base + | |- S' (s _) :' ?T => apply tensor_smpl_inc + | |- S' 0 :' ?T => apply tensor_smpl_base + | |- T' (s _) :' ?T => apply tensor_smpl_inc + | |- T' 0 :' ?T => apply tensor_smpl_base + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with wfvt_db) + | |- ?g :' ?A → ?B => tryif is_evar A then fail else + solve [eauto with base_types_db] + | |- ?A = ?B => try easy + end. + +match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- WFS_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A .⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => idtac 4 + end. + + +rewrite decompose_tensor_mult_r. + apply arrow_mul; type_check_base. + 3 : { + + +match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- WFS_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A .⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) -> _ => rewrite decompose_tensor_mult_r + | |- CNOT (s _) (s _) :' ?T => apply tensor_ctrl_inc + | |- CNOT 0 (s (s _)) :' ?T => apply tensor_ctrl_inc_r + | |- CNOT (s (s _)) 0 :' ?T => apply tensor_ctrl_inc_l + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_base_inv + | |- CNOT 0 1 :' ?T => apply tensor_ctrl_base + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_comm + | |- H' (s _) :' ?T => apply tensor_smpl_inc + | |- H' 0 :' ?T => apply tensor_smpl_base + | |- S' (s _) :' ?T => apply tensor_smpl_inc + | |- S' 0 :' ?T => apply tensor_smpl_base + | |- T' (s _) :' ?T => apply tensor_smpl_inc + | |- T' 0 :' ?T => apply tensor_smpl_base + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with wfvt_db) + | |- ?g :' ?A → ?B => tryif is_evar A then fail else + solve [eauto with base_types_db] + | |- ?A = ?B => try easy + end. + +match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- WFS_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A .⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => rewrite decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) -> _ => rewrite decompose_tensor_mult_r + | |- CNOT (s _) (s _) :' ?T => apply tensor_ctrl_inc + | |- CNOT 0 (s (s _)) :' ?T => apply tensor_ctrl_inc_r + | |- CNOT (s (s _)) 0 :' ?T => apply tensor_ctrl_inc_l + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_base_inv + | |- CNOT 0 1 :' ?T => apply tensor_ctrl_base + | |- CNOT 1 0 :' ?T => apply tensor_ctrl_comm + | |- H' (s _) :' ?T => apply tensor_smpl_inc + | |- H' 0 :' ?T => apply tensor_smpl_base + | |- S' (s _) :' ?T => apply tensor_smpl_inc + | |- S' 0 :' ?T => apply tensor_smpl_base + | |- T' (s _) :' ?T => apply tensor_smpl_inc + | |- T' 0 :' ?T => apply tensor_smpl_base + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with wfvt_db) + | |- ?g :' ?A → ?B => tryif is_evar A then fail else + solve [eauto with base_types_db] + | |- ?A = ?B => try easy + end. + + 3 : { + + match goal with + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + rewrite (decompose_tensor A B) by (auto 50 with wfvt_db) + end; auto with wfvt_db; try easy. + + + type_check_base'. + type_check_base'. + type_check_base'. + type_check_base'. + type_check_base'. + type_check_base'. + kill_switch2. + + + repeat (repeat (rewrite switch_vType_inc; auto with gt_db); + try rewrite switch_vType_base; try rewrite switch_vType_base_one; + auto with gt_db). + + + + + + + kill_ + + + type_check_base'. + type_check_base'. + + + +apply evSuper_ev; auto 50 with wfvt_db. + unfold eq_vType; simpl. + apply hd_inj; unfold uncurry; simpl. + apply TType_compare; auto; simpl. + repeat (split; try lma'). + unfold translate + + + + + + + + +Check hd_inj. + + repeat (apply wfs_switch_vType'; auto 50 with wfvt_db). + apply wfs_switch_vType'; auto 50 with wfvt_db. + apply wfs_switch_vType'; auto with wfvt_db. + + +3 : { + unfold eq_vType. simpl. + unfold translate. simpl. + unfold translate_vecType + + + type_check_base'. + type_check_base'. + type_check_base'. + type_check_base'. + type_check_base'. + type_check_base'. + type_check_base'. + +rewrite mul_tensor_dist; auto with wfvt_db. + easy. + +type_check_base'. + type_check_base'. + 3 : { rewrite mul_compat. + try rewrite mul_tensor_dist; + try easy; auto with wfvt_db. + + +pushA. + all : auto with gt_db. + type_check_base'. + type_check_base'. + all : try pushA. + all : try pushA. + + 3 : { pushA. + 3 : pushA. + all : auto with wfvt_db. } + all : auto with gt_db. + type_check_base'. + 3 : { pushA rewrite mul_compat; + try rewrite mul_tensor_dist; + try easy; auto with wfvt_db. + 3 : { rewrite mul_compat; + try rewrite mul_tensor_dist; + try easy; auto with wfvt_db. + 3 : rewrite mul_compat; + try rewrite mul_tensor_dist; + try easy; auto with wfvt_db. + all : auto with wfvt_db. } + all : auto with wfvt_db. } + all : auto with gt_db. + type_check_base'. + unfold eq_vType. + simpl switch_vType'. + unfold translate. simpl. + apply hd_inj. + crunch_matrix. +try easy. + + type_check_base'. + + 2 : { simp_switch. + + +rewrite nth_vswitch_hit. try easy; try lia; auto with gt_db). + repeat (rewrite nth_vswitch_miss; try easy; try lia; auto with gt_db). + +match goal with + | |- ?g :' nth_vType ?n (switch_vType' _ _ ?n) → _ => + rewrite nth_vswitch_hit; try easy; try lia; auto with gt_db + | |- ?g :' nth_vType ?n (switch_vType' _ _ ?m) → _ => + rewrite nth_vswitch_miss; try easy; try nia; auto with gt_db +end. +match goal with + | |- ?g :' nth_vType ?n (switch_vType' _ _ ?n) → _ => + rewrite nth_vswitch_hit; try easy; try lia; auto with gt_db + | |- ?g :' nth_vType ?n (switch_vType' _ _ ?m) → _ => + rewrite nth_vswitch_miss; try easy; try nia; auto with gt_db +end. + + + +nth_vType bit (switch_vType' A a bit) = a. + + + => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ + + + + econstructor; reflexivity. + + + rewrite nth_vswitch_miss; try easy; try nia; auto with gt_db. + rewrite nth_vswitch_hit; [| nia | | |]. try easy; try nia; auto with gt_db. + + + +rewrite nth_vswitch_hit; try easy; try lia; auto with gt_db. + + + simpl nth_vType. + apply arrow_mul_1. + solve [eauto with base_types_db]. + solve [eauto with base_types_db]. + eapply tensor_ctrl. + simpl nth_vType. + type_check_base'. + + 2 : { simp_switch. + + +solve [eauto with base_types_db]. type_check_base'. } + all : try type_check_base' + try rewrite nth_vswitch_miss; try easy; try nia; auto with gt_db; + try rewrite nth_vswitch_hit; try easy; try nia; auto with gt_db. + 2 : { type_check_base'. } + type_check_base'. + + type_check_base'. + + + 3 : { rewrite mul_tensor_dist. easy. + + + type_check_base. + + simpl nth_vType. + assert (H : G 1 (p_1, [gMul gX gZ]) = X .* Z). + { easy. } + rewrite H. + type_check_base. + eapply tensor_ctrl. + apply prog_decompose_tensor; auto with wfvt_db. + eapply eq_arrow_r. + apply arrow_mul; auto with wfvt_db; try solve [eauto with base_types_db]. + 5 : { simpl nth_vType. + + type_check_base. + +repeat match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply tensor_ctrl + | |- H' (S ?n) :' ?T => eapply tensor_smpl; auto with wfvt_db + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end; auto with wfvt_db. + + + + + + match goal with + | |- Sing_vt _ => auto 50 with svt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply tensor_ctrl + | |- H' (S ?n) :' ?T => eapply tensor_smpl; auto with wfvt_db + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end. +match goal with + | |- Sing_vt _ => auto 50 with svt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply tensor_ctrl + | |- H' (S ?n) :' ?T => eapply tensor_smpl; auto with wfvt_db + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end. + + + +match goal with + | |- Sing_vt _ => auto 50 with svt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply tensor_ctrl + | |- H' (S ?n) :' ?T => eapply tensor_smpl; auto with wfvt_db + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end; auto with wfvt_db. + + +match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply tensor_ctrl + | |- H' (S ?n) :' ?T => eapply tensor_smpl; auto with wfvt_db + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end; + +try match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply tensor_ctrl + | |- H' (S ?n) :' ?T => eapply tensor_smpl; auto with wfvt_db + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end; + +match goal with + | |- Sing_vt ?A => tryif is_evar A then fail else auto 50 with svt_db + | |- WF_vType ?A => tryif is_evar A then fail else auto with wfvt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply tensor_ctrl + | |- H' (S ?n) :' ?T => eapply tensor_smpl; auto with wfvt_db + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end. easy. + + +match goal with + | |- Sing_vt _ => tryif is_evar A then fail else auto 50 with svt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply tensor_ctrl + | |- H' (S ?n) :' ?T => eapply tensor_smpl; auto with wfvt_db + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end. + + type_check_base. + + +Lemma superdenseTypesQPL' : superdense :' (Z .⊗ Z .⊗ Z .⊗ Z → I .⊗ I .⊗ Z .⊗ Z). +Proof. repeat expand_prog. + type_check_base'. + + eapply tensor_ctrl'; try (apply prog_decompose_tensor); try easy; + try (eapply eq_arrow_r; apply arrow_mul; try (solve [eauto with base_types_db])). + + 3: { eapply eq_arrow_r. apply arrow_mul; try (solve [eauto with base_types_db]); + try (auto with wfvt_db). + rewrite mul_tensor_dist; + auto with wfvt_db; easy. } + auto with gt_db. + auto with gt_db. + + eapply tensor_smpl. + simpl. easy. + auto with wfvt_db. + rewrite nth_vswitch_miss; try easy; try nia; auto with gt_db. + rewrite nth_vswitch_hit; try easy; try nia; auto with gt_db. + eapply eq_arrow_r. + apply arrow_mul; try (solve [eauto with base_types_db]); try (auto with wfvt_db). + easy. + solve [eauto with base_types_db]. + 9: { solve [eauto with base_types_db]. } + +Lemma superdenseTypesQPL' : superdense :' (Z .⊗ Z .⊗ Z .⊗ Z → I .⊗ I .⊗ Z .⊗ Z). +Proof. repeat expand_prog. + type_check_base'. + + eapply tensor_ctrl'; try (apply prog_decompose_tensor); try easy; + try (eapply eq_arrow_r; apply arrow_mul; try (solve [eauto with base_types_db])). + + 3: { eapply eq_arrow_r. apply arrow_mul; try (solve [eauto with base_types_db]); + try (auto with wfvt_db). + rewrite mul_tensor_dist; + auto with wfvt_db; easy. } + auto with gt_db. + auto with gt_db. + + eapply tensor_smpl. + simpl. easy. + auto with wfvt_db. + rewrite nth_vswitch_miss; try easy; try nia; auto with gt_db. + rewrite nth_vswitch_hit; try easy; try nia; auto with gt_db. + eapply eq_arrow_r. + apply arrow_mul; try (solve [eauto with base_types_db]); try (auto with wfvt_db). + easy. + solve [eauto with base_types_db]. + 9: { solve [eauto with base_types_db]. } + + + + repeat expand_prog. + repeat match goal with + | |- Sing_vt _ => auto 50 with svt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply (tensor_ctrl (S n) m _ _ _) + | |- ?g (S ?n) :' ?T => eapply (tensor_smpl (S n) _ _ _) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end. + eapply (tensor_ctrl 2 3 _ _ _). + match goal with + | |- Sing_vt _ => auto 50 with svt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply (tensor_ctrl (S n) m _ _ _) + | |- ?g (S ?n) :' ?T => idtac 4 + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end. + + + + + + + + +repeat apply cap_intro; + repeat expand_prog; (* will automatically unfold compound progs *) + repeat match goal with + | |- Sing_vt _ => auto 50 with svt_db + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g :' - ?A → ?B => apply arrow_neg + | |- ?g :' i ?A → ?B => apply arrow_i + | |- context[?A ⊗ ?B] => progress (autorewrite with tensor_db) + | |- ?g :' ?A → ?B => tryif is_evar B then fail else eapply eq_arrow_r + | |- ?g 0 1 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI2)); + solve [eauto with base_types_db] + | |- ?g 0 :' ?A → ?B => tryif is_evar A then fail else + (try (eapply TypesI)); + solve [eauto with base_types_db] + | |- ?g (S ?n) ?m :' ?T => eapply (tensor_ctrl (S n) m _ _ _) + | |- ?g (S ?n) :' ?T => eapply (tensor_smpl (S n) _ _ _) + | |- ?g :' ?A .* ?B → _ => apply arrow_mul + | |- ?g :' (?A .* ?B) .⊗ I → _ => apply prog_decompose_tensor_mult_l + | |- ?g :' I .⊗ (?A .* ?B) → _ => apply prog_decompose_tensor_mult_r + | |- ?g :' ?A .⊗ ?B → _ => tryif (is_I A + is_I B) then fail else + apply prog_decompose_tensor + | |- ?A ≡ ?B => try easy + end. + + +repeat match goal with + | |- ?p1 ;; ?p2 :' ?T => eapply SeqTypes + end. + eapply (tensor_smpl 2 _ _ _). + solve [eauto with base_types_db]. + eapply (tensor_ctrl 4 2 3 _ _ _). + simpl nth_vType. + apply prog_decompose_tensor; try easy. + eapply eq_arrow_r. + apply arrow_mul; + try (solve [eauto with base_types_db]); + try easy. + rewrite mul_tensor_dist; try easy. + eapply (tensor_ctrl 2 _ _ _). + simpl. + solve [eauto with base_types_db]. + + + +reflexivity. +try easy. + 5: { solve [eauto with base_types_db]. } + 5: { solve [eauto with base_types_db]. } + + + + + auto with univ_db. + auto with univ_db. + nia. + easy. + eapply (tensor_ctrl 4 2 3 _ _ _). + rewrite CX_is_CNOT. + rewrite decompose_tensor. + eapply eq_arrow_r. + apply arrow_mul. + auto with sing_db. + auto with sing_db. + auto with unit_db. + auto with univ_db. + 4: { solve [eauto with base_types_db]. } + auto with univ_db. + auto with univ_db. + + + +emma prog_decompose_tensor : forall (p : prog) (A B : vType 1) (T : vType 2), + Sing_vt A -> WF_vType A -> + Sing_vt B -> WF_vType B -> + p :' ((A .⊗ I) .* (I .⊗ B)) → T -> p :' (A .⊗ B) → T. +Proof. intros. + apply (eq_type_conv_input p ((A .⊗ I) .* (I .⊗ B)) (A .⊗ B) T); try easy. + rewrite <- decompose_tensor; easy. +Qed. + + + + rewrite decompose_tensor. + eapply eq_arrow_r. + apply arrow_mul. + auto with sing_db. + auto with sing_db. + auto with unit_db. + auto with univ_db. + + + + assert (H : G 1 (p_1, [gX]) = X). { easy. } + assert (H' : G 1 (p_1, [gZ]) = Z). { easy. } + rewrite H, H'. + + +solve [eauto with base_types_db]. } + auto with univ_db. + auto with univ_db. + 2: { solve [eauto with base_types_db]. } + auto with univ_db. + rewrite mul_tensor_dist. + reflexivity. + auto with sing_db. + auto with sing_db. + auto with sing_db. + auto with sing_db. + eapply (tensor_ctrl 4 0 2 _ _ _). + rewrite decompose_tensor. + eapply eq_arrow_r. + + +Ltac is_I A := + match A with + + +Definition vecTypeT (len : nat) := (list (vecType 2)). + +| tensor : GType -> GType -> GType +| cap : GType -> GType -> GType +| arrow : GType -> GType -> GType. + +Notation "- T" := (neg T). +Infix ".*" := mul (at level 40, left associativity). +Infix ".⊗" := tensor (at level 51, right associativity). +Infix "→" := arrow (at level 60, no associativity). +Infix "∩" := cap (at level 60, no associativity). + +Notation Y := (i (X .* Z)). + + +Fixpoint singGType (g : GType) := + match g with + | I => + | X => + | Z => + | i g => + | neg g => + | mul g1 g2 => + | tensor g1 g2 => + | + + + +Fixpoint translate (g : GType) := + match g with + | gI => I'' + | gX => X'' + | gZ => Z'' + | gmul g1 g2 => mulT' (translate g1) (translate g2) + | gtensor g1 g2 => tensorT (translate g1) (translate g2) + | gi g => scaleT Ci (translate g) + | gneg g => scaleT (Copp C1) (translate g) + | _ => I'' + end. + + + +Parameter GType : Type. +Parameter I : GType. +Parameter X : GType. +Parameter Z : GType. +Parameter i : GType -> GType. +Parameter neg : GType -> GType. +Parameter mul : GType -> GType -> GType. +Parameter tensor : GType -> GType -> GType. +Parameter cap : GType -> GType -> GType. +Parameter arrow : GType -> GType -> GType. + + +(* +Parameter toGType : Matrix 2 2 -> GType. +Axiom ItoG : toGType (Matrix.I 2) = I. +Axiom XtoG : toGType σx = X. +Axiom ZtoG : toGType σz = Z. +*) + + +Notation "- T" := (neg T). +Infix "*" := mul (at level 40, left associativity). +Infix "⊗" := tensor (at level 51, right associativity). +Infix "→" := arrow (at level 60, no associativity). +Infix "∩" := cap (at level 60, no associativity). + +Notation Y := (i (X * Z)). + +(* Singleton Types *) +(* Could probably safely make this inductive. Can't do inversion on GTypes anyhow. *) + +Parameter Singleton : GType -> Prop. +Axiom SI: Singleton I. +Axiom SX : Singleton X. +Axiom SZ : Singleton Z. +Axiom S_neg : forall A, Singleton A -> Singleton (neg A). +Axiom S_i : forall A, Singleton A -> Singleton (i A). +Axiom S_mul : forall A B, Singleton A -> Singleton B -> Singleton (A * B). + +Hint Resolve SI SX SZ S_neg S_i S_mul : sing_db. + +Lemma SY : Singleton Y. +Proof. auto with sing_db. Qed. + +(* Multiplication laws *) + +Axiom mul_assoc : forall A B C, A * (B * C) = A * B * C. +Axiom mul_I_l : forall A, I * A = A. +Axiom mul_I_r : forall A, A * I = A. +Axiom Xsqr : X * X = I. +Axiom Zsqr : Z * Z = I. +Axiom ZmulX : Z * X = - (X * Z). + +Axiom neg_inv : forall A, - - A = A. +Axiom neg_dist_l : forall A B, -A * B = - (A * B). +Axiom neg_dist_r : forall A B, A * -B = - (A * B). + +Axiom i_sqr : forall A, i (i A) = -A. +Axiom i_dist_l : forall A B, i A * B = i (A * B). +Axiom i_dist_r : forall A B, A * i B = i (A * B). + +Axiom i_neg_comm : forall A, i (-A) = -i A. + +Hint Rewrite mul_I_l mul_I_r Xsqr Zsqr ZmulX neg_inv neg_dist_l neg_dist_r i_sqr i_dist_l i_dist_r i_neg_comm : mul_db. + +(** ** Tensor Laws *) + +Axiom tensor_assoc : forall A B C, A ⊗ (B ⊗ C) = (A ⊗ B) ⊗ C. + +Axiom neg_tensor_dist_l : forall A B, -A ⊗ B = - (A ⊗ B). +Axiom neg_tensor_dist_r : forall A B, A ⊗ -B = - (A ⊗ B). +Axiom i_tensor_dist_l : forall A B, i A ⊗ B = i (A ⊗ B). +Axiom i_tensor_dist_r : forall A B, A ⊗ i B = i (A ⊗ B). + +(** ** Multiplication & Tensor Laws *) + +(* Appropriate restriction is that size A = size C and size B = size D, + but axiomatization doesn't allow for that calculation. *) +(* This should be generalizable to the other, assuming we're multiplying + valid types. *) +Axiom mul_tensor_dist : forall A B C D, + Singleton A -> + Singleton C -> + (A ⊗ B) * (C ⊗ D) = (A * C) ⊗ (B * D). + +Lemma decompose_tensor : forall A B, + Singleton A -> + Singleton B -> + A ⊗ B = (A ⊗ I) * (I ⊗ B). +Proof. + intros. + rewrite mul_tensor_dist; auto with sing_db. + rewrite mul_I_l, mul_I_r. + easy. +Qed. + +Lemma decompose_tensor_mult_l : forall A B, + Singleton A -> + Singleton B -> + (A * B) ⊗ I = (A ⊗ I) * (B ⊗ I). +Proof. + intros. + rewrite mul_tensor_dist; auto with sing_db. + rewrite mul_I_l. + easy. +Qed. + +Lemma decompose_tensor_mult_r : forall A B, + I ⊗ (A * B) = (I ⊗ A) * (I ⊗ B). +Proof. + intros. + rewrite mul_tensor_dist; auto with sing_db. + rewrite mul_I_l. + easy. +Qed. + +Hint Rewrite neg_tensor_dist_l neg_tensor_dist_r i_tensor_dist_l i_tensor_dist_r : tensor_db. + +(** ** Intersection Laws *) + +Axiom cap_idem : forall A, A ∩ A = A. + +Axiom cap_comm : forall A B, A ∩ B = B ∩ A. + +Axiom cap_assoc : forall A B C, A ∩ (B ∩ C) = (A ∩ B) ∩ C. + +Axiom cap_I_l : forall A, + Singleton A -> + I ∩ A = A. + +Lemma cap_I_r : forall A, + Singleton A -> + A ∩ I = A. +Proof. intros; rewrite cap_comm, cap_I_l; easy. Qed. + + +(* Note: I haven't proven that this works or terminates. + An anticommutative monoidal solver would be ideal here. *) +Ltac normalize_mul := + repeat match goal with + | |- context[(?A ⊗ ?B) ⊗ ?C] => rewrite <- (tensor_assoc A B C) + end; + repeat (rewrite mul_tensor_dist by auto with sing_db); + repeat rewrite mul_assoc; + repeat ( + try rewrite <- (mul_assoc X Z _); + autorewrite with mul_db tensor_db; + try rewrite mul_assoc ). + + + +Lemma Ysqr : Y * Y = I. Proof. +autorewrite with mul_db. +try rewrite mul_assoc. +try rewrite <- (mul_assoc X Z _). +autorewrite with mul_db. +try rewrite mul_assoc. +try rewrite <- (mul_assoc X Z _). +autorewrite with mul_db. + + reflexivity. Qed. +Lemma XmulZ : X * Z = - Z * X. Proof. normalize_mul. reflexivity. Qed. +Lemma XmulY : X * Y = i Z. Proof. normalize_mul. reflexivity. Qed. +Lemma YmulX : Y * X = -i Z. Proof. normalize_mul. reflexivity. Qed. +Lemma ZmulY : Z * Y = -i X. Proof. normalize_mul. reflexivity. Qed. +Lemma YmulZ : Y * Z = i X. Proof. normalize_mul. reflexivity. Qed. + + + +Fixpoint zipWith {X : Type} (f : X -> X -> X) (As Bs : list X) : list X := + match As with + | [] => Bs + | a :: As' => + match Bs with + | [] => As + | b :: Bs' => f a b :: zipWith f As' Bs' + end + end. + + +Lemma zipWith_len_pres : forall {X : Type} (f : X -> X -> X) (n : nat) + (As : list X) (Bs : list X), + length As = n -> length Bs = n -> length (zipWith f As Bs) = n. +Proof. induction n as [| n']. + - intros. + destruct As; destruct Bs; easy. + - intros. + destruct As; destruct Bs; try easy. + simpl in *. + apply Nat.succ_inj in H; apply Nat.succ_inj in H0. + rewrite IHn'; easy. +Qed. + + +Lemma zipWith_app_product : forall {X : Type} (f : X -> X -> X) (n : nat) + (l0s l2s : list X) (l1s l3s : list X), + length l0s = n -> length l1s = n -> + (zipWith f l0s l1s) ++ (zipWith f l2s l3s) = zipWith f (l0s ++ l2s) (l1s ++ l3s). +Proof. induction n as [| n']. + - intros. destruct l0s; destruct l1s; easy. + - intros. destruct l0s; destruct l1s; try easy. + unfold zipWith in *. + simpl in *. + rewrite <- IHn'; try nia. + reflexivity. +Qed. diff --git a/_CoqProject b/_CoqProject index e5e257c..31d93bb 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,5 +1,6 @@ -R . Top +<<<<<<< HEAD Ancilla.v Complex.v Composition.v @@ -22,3 +23,17 @@ SemanticLib.v Symmetric.v TypeChecking.v UnitarySemantics.v +======= +Complex.v +Eigenvectors.v +Heisenberg.v +Matrix.v +Monad.v +Monoid.v +Polynomial.v +Prelim.v +Quantum.v +RealAux.v +Types.v + +>>>>>>> Heisenberg-Foundations/main