Mercurial > hg > Papers > 2021 > soto-thesis
changeset 3:959f4b34d6f4
add final thesis
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/final_thesis.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,116 @@ +\documentclass[a4j,12pt]{ltjreport} + +\usepackage{graphicx} +\usepackage{fancyhdr} +\usepackage{bmpsize} +\usepackage{here} +\usepackage{listings} +\usepackage{comment} + +% sty +\usepackage{picins} +\usepackage{mythesis} + +%\pagestyle{empty} +\usepackage{multirow} + +% 特殊文字の表示 +\usepackage{luatexja} +\usepackage{fontspec} +\setmainfont{STIX Math} +\setmonofont{STIXGeneralBol}[ + Scale=MatchLowercase +] +\usepackage{caption} + +% フォント +%\usepackage{luatexja-fontspec} +%\usepackage[hiragino-pro]{luatexja-preset} + +%\special{pdf:mapline rml H meiryo.ttc} +%\special{pdf:mapline gbm H meiryo.ttc} +%\usepackage[hiragino-pro]{pxchfon} + +\lstset{ + frame=single, + keepspaces=true, + stringstyle={\ttfamily}, + commentstyle={\ttfamily}, + identifierstyle={\ttfamily}, + keywordstyle={\ttfamily}, + basicstyle={\ttfamily}, + breaklines=true, + xleftmargin=0\zw, + xrightmargin=0\zw, + framerule=.3pt, + columns=[l]{fullflexible}, + numbers=left, + stepnumber=1, +% numberstyle={\scriptsize}, + numbersep=5pt, + language={}, + tabsize=4, + lineskip=-0.1\zw, + escapechar={@}, +} + +% bibtex +\usepackage[backend=biber, style=numeric, bibstyle=ieee]{biblatex} +\nocite{*} +\addbibresource{soto.bib} + +\usepackage{indentfirst} +\usepackage{url} +\usepackage{amssymb} + +% コマンド類 +\def\lstlistlistingname{リスト目次} +\newcommand\figref[1]{図 \ref{#1}} +\newcommand\coderef[1]{ソースコード \ref{#1}} + +% 表紙 +\setlength{\itemsep}{-1\zh} +\title{\fontsize{24pt}{24pt}\selectfont Continuation based C による RedBlackTree の \\ Hoare Logic を用いた検証} +\icon{\includegraphics[width=50mm]{pic/ryukyu.pdf}} +\year{令和2年度 卒業論文} +\belongto{琉球大学工学部工学科知能情報コース} +\author{175707H 氏名 {上地 悠斗}\\ 指導教員 : {河野 真治} } + +% 目次 +\makeatletter +\renewcommand{\lstlistlistingname}{ソースコード目次} +\newcommand{\figcaption}[1]{\def\@captype{figure}\caption{#1}} +\newcommand{\tblcaption}[1]{\def\@captype{table}\caption{#1}} +\makeatother +\setlength\abovecaptionskip{0pt} + +\begin{document} +\ltjsetparameter{jacharrange={-3}} +\maketitle +\baselineskip 17pt plus 1pt minus 1pt + +\setcounter{page}{0} + +\setcounter{tocdepth}{2} +\setcounter{secnumdepth}{2} +\pagenumbering{roman} % ページ番号 +\tableofcontents +\listoffigures % 図目次 +\listoftables % 表目次 +\lstlistoflistings + +%\thispagestyle{fancy} + +\input{tex/intro.tex} % はじめに +\input{tex/cbc.tex} % CbC の説明 +\input{tex/agda.tex} % agda の説明 +\input{tex/hoare.tex} % Hoare Logic の説明 +\input{tex/cbc_agda.tex}% continuation 形式で書くagda +\input{tex/rbt_intro.tex} % 赤黒木の説明 +\input{tex/rbt_imple.tex}% 手法 +\input{tex/rbt_verif.tex}% 検証 +\input{tex/future.tex}% 今後の課題 +\input{tex/thanks.tex} % 謝辞 +\printbibliography[title={参考文献}] + +\end{document}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/mythesis.sty Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,153 @@ +% +% 卒業論文スタイルファイル(mythesis.sty) +% version 1.0e +% +% ver 1.0e 02/07/2000 since +% usage: + +%\documentclass[a4j]{jreport} +%\usepackage{master_paper} +% +% +%\title{卒論タイトル \\ 長い} +%\etitle{\pLaTeX2e style test file for Teri's thesis } +%\year{平成11年度} +%\belongto{琉球大学大学工学部\\ 情報工学科} +%\author{豊平 絵梨} +% +%\begin{document} +% +%\maketitle +% +%%要旨 +%\input{abstract.tex} +% +%%目次 +%\tableofcontents +% +%%図目次 +%\listoffigures +% +%%表目次 +%\listoftables +% +%%第一章 +%\input{chapter1.tex} +%%chapter1.texの\chapter{}の後ろに次のコマンドを追加してください。 +%%ページカウントがリセットされ、ページ数がアラビア文字になります。 +%% \pagenumbering{arabic} +%%第二章 +%\input{chapter2.tex} +%%第三章 +%\input{chapter3.tex} +% +%%付録 +%\input{appendix.tex} +% +%%謝辞 +%%\input{thanx.tex} +% +%%参考文献 +%\input{biblography.tex} +% +%\end{document} + + +%長さ設定 +%\setlength{\topmargin}{-30mm} +%\addtolength{\oddsidemargin}{-15mm} +%\addtolength{\textwidth}{60mm} + +\topmargin -1in \addtolength{\topmargin}{35mm} +\headheight 0mm +\headsep 0mm +\oddsidemargin -1in \addtolength{\oddsidemargin}{30mm} +%\evensidemargin -1in \addtolength{\evensidemargin}{8mm} +\textwidth 160mm +\textheight 230mm +%\footheight 0mm +%\footskip 0mm +%\pagestyle{empty} + + +%年度 +\def\@year{} +\def\year#1{\gdef\@year{#1}} +%英文タイトル +\def\@etitle{} +\def\etitle#1{\gdef\@etitle{#1}} +%アイコン +\def\@icon{} +\def\icon#1{\gdef\@icon{#1}} +%所属 +\def\@belongto{} +\def\belongto#1{\gdef\@belongto{#1}} + +%表紙 +\renewcommand{\maketitle}{% +\newpage\null +\thispagestyle{empty} +\vskip 0cm% +\begin{center}% +\let\footnote\thanks + {\huge \@year \par}% + \vskip 3em% + {\Huge \@title \par}% + \vskip 1em% + {\huge \@etitle \par}% + \vskip 8em% + {\huge \@icon \par}% + \vskip 0.5em% + {\huge \@belongto \par}% + \vskip 1.0em% + {\huge \@author \par}% + +\end{center}% +\par\vskip 1.5em +} + +%abstract +\renewenvironment{abstract}{% + \titlepage + \thispagestyle{empty} + \null\vfil + \@beginparpenalty\@lowpenalty + {\Huge \bfseries \abstractname}% + \begin{center}% + \@endparpenalty\@M + \end{center} +} + +%目次 +% \renewcommand{\tableofcontents}{% +% \pagestyle{plain} +% \if@twocolumn\@restonecoltrue\onecolumn +% \else\@restonecolfalse\fi +% \chapter*{\contentsname +% \@mkboth{\contentsname}{\contentsname}% +% } \pagenumbering{roman}\@starttoc{toc}% +% \if@restonecol\twocolumn\fi +% } + +%章 +% \renewcommand{\chapter}{} +% \pagestyle{plain} +% \if@openright\cleardoublepage\else\clearpage\fi +% \thispagestyle{jplain}% +% \global\@topnum\z@ +% \@afterindentfalse +% \secdef\@chapter\@schapter} + +\renewcommand{\prepartname}{} %\renewcommand{\prepartname}{第} +\renewcommand{\postpartname}{部} +\renewcommand{\prechaptername}{第}%\renewcommand{\prechaptername}{第} +\renewcommand{\postchaptername}{章} +\renewcommand{\contentsname}{目 次} +\renewcommand{\listfigurename}{図 目 次} +\renewcommand{\listtablename}{表 目 次} +%\renewcommand{\bibname}{参考文献} +\renewcommand{\indexname}{索 引} +\renewcommand{\figurename}{図} +\renewcommand{\tablename}{表} +\renewcommand{\appendixname}{付 録} +\renewcommand{\abstractname}{要 旨}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/picins.sty Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,578 @@ +% PICINS.STY --- Style File zum Einbinden von Bildern +% Autor: J. Bleser, E. Lang +% Hochschulrechenzentrum +% Technische Hochschule Darmstadt +% !!! Dieses Style-File ist urheberrechtlich geschuetzt !!! +% !!! Aenderungen nur mit Zustimmung der Autoren !!! +\message{Option `picins' Version 3.0 Sep. 1992, TH Darmstadt/HRZ} +\newbox\@BILD% +\newbox\@TEXT% +\newdimen\d@breite% +\newdimen\d@hoehe% +\newdimen\d@xoff% +\newdimen\d@yoff% +\newdimen\d@shad% +\newdimen\d@dash% +\newdimen\d@boxl% +\newdimen\d@pichskip% +\newdimen\d@tmp +\newdimen\d@tmpa +\newdimen\d@bskip +\newdimen\hsiz@% +\newdimen\p@getot@l% +\newcount\c@breite +\newcount\c@hoehe +\newcount\c@xoff +\newcount\c@yoff +\newcount\c@pos +\newcount\c@shad +\newcount\c@dash +\newcount\c@boxl +\newcount\c@zeilen% +\newcount\@changemode% +\newcount\c@piccaption% +\newcount\c@piccaptionpos% +\newcount\c@picpos +\newcount\c@whole% +\newcount\c@half% +\newcount\c@tmp +\newcount\c@tmpa +\newcount\c@tmpb +\newcount\c@tmpc +\newcount\c@tmpd +\newskip\d@leftskip +\newif\if@list \@listfalse% +\newif\if@offset% + + +\c@piccaptionpos=1% +\c@picpos=0 +\d@shad=4pt% +\d@dash=4pt% +\d@boxl=10pt% +\d@pichskip=1em% +\@changemode=0% +\def\@captype{figure}% +\let\old@par=\par% + +\def\pichskip#1{\d@pichskip #1\relax} + + +\def\shadowthickness#1{\d@shad #1\relax} + + +\def\dashlength#1{\d@dash #1\relax} + + +\def\boxlength#1{\d@boxl #1\relax} + + +\def\picchangemode{\@changemode=1}% +\def\nopicchangemode{\@changemode=0}% + + +\def\piccaptionoutside{\c@piccaptionpos=1}% +\def\piccaptioninside{\c@piccaptionpos=2}% +\def\piccaptionside{\c@piccaptionpos=3}% +\def\piccaptiontopside{\c@piccaptionpos=4}% + +\def\piccaption{\@ifnextchar [{\@piccaption}{\@piccaption[]}} +\def\@piccaption[#1]#2{\c@piccaption=1\def\sh@rtf@rm{#1}\def\capti@nt@xt{#2}} +\def\make@piccaption{% + \hsiz@\d@breite% + \ifnum\c@piccaptionpos=2% + \advance\hsiz@ -2\fboxsep% + \fi% + \ifnum\c@piccaptionpos>2% + \hsiz@\hsize\advance\hsiz@-\d@breite\advance\hsiz@-\d@pichskip% + \fi% + \setbox\@TEXT=\vbox{\hsize\hsiz@\caption[\sh@rtf@rm]{\capti@nt@xt}}% +} + + + +\def\newcaption{\refstepcounter\@captype\@dblarg{\@newcaption\@captype}} +\long\def\@newcaption#1[#2]#3{% + \old@par% + \addcontentsline{\csname ext@#1\endcsname }{#1}% + {\protect\numberline{\csname the#1\endcsname}{\ignorespaces #2}} + \begingroup\@parboxrestore\normalsize% + \@newmakecaption{\csname fnum@#1\endcsname}{\ignorespaces #3}\old@par% + \endgroup% +} +\long\def\@newmakecaption#1#2{% + \vskip 10pt% + \setbox\@tempboxa \hbox {#1: #2}% + \ifdim \wd\@tempboxa >\hsize% + \setbox0=\hbox{#1: }\dimen0=\hsize\advance\dimen0 by-\wd0 + \setbox1=\vtop{\hsize=\dimen0 #2} + \hbox{\box0 \box1} + \par + \else \hbox to\hsize {\hfil \box \@tempboxa \hfil} + \fi +} + + + + + +\def\parpic{% + \@ifnextchar ({\iparpic}{\iparpic(0pt,0pt)} +} +\def\iparpic(#1,#2){% + \@ifnextchar ({\@offsettrue\iiparpic(#1,#2)}% + {\@offsetfalse\iiparpic(#1,#2)(0pt,0pt)} +} +\def\iiparpic(#1,#2)(#3,#4){% + \@ifnextchar [{\iiiparpic(#1,#2)(#3,#4)}{\iiiparpic(#1,#2)(#3,#4)[l]} +} +\def\iiiparpic(#1,#2)(#3,#4)[#5]{% + \@ifnextchar [{\ivparpic(#1,#2)(#3,#4)[#5]}{\ivparpic(#1,#2)(#3,#4)[#5][]} +} +\def\ivparpic(#1,#2)(#3,#4)[#5][#6]#7{% + \let\par=\old@par\par% + \hangindent0pt\hangafter1% + \setbox\@BILD=\hbox{#7}% + \d@breite=#1\d@breite=\the\d@breite% + \ifdim\d@breite=0pt\d@breite=\wd\@BILD\fi% + \c@breite=\d@breite\divide\c@breite by65536% + \multiply\c@piccaption\c@piccaptionpos% + \d@hoehe=#2\d@hoehe=\the\d@hoehe% + \ifdim\d@hoehe=0pt\d@hoehe=\ht\@BILD\advance\d@hoehe by\dp\@BILD\fi% + \c@hoehe=\d@hoehe\divide\c@hoehe by65536% + \d@xoff=#3\c@xoff=\d@xoff\divide\c@xoff by65536% + \d@yoff=\d@hoehe% + \advance\d@yoff by-#4\c@yoff=\d@yoff\divide\c@yoff by65536% + \c@pos=1\unitlength1pt% + \if@offset% + \setbox\@BILD=\hbox{% + \begin{picture}(\c@breite,\c@hoehe)% + \put(0,0){\makebox(\c@breite,\c@hoehe){}}% + \put(\c@xoff,\c@yoff){\box\@BILD}% + \end{picture}% + }% + \else% + \setbox\@BILD=\hbox{% + \begin{picture}(\c@breite,\c@hoehe)% + \put(0,0){\makebox(\c@breite,\c@hoehe)[#6]{\box\@BILD}}% + \end{picture}% + }% + \fi% + \ifnum\c@piccaption=2% + \make@piccaption% + \advance\d@hoehe\ht\@TEXT\advance\d@hoehe\dp\@TEXT% + \c@hoehe=\d@hoehe\divide\c@hoehe by65536% + \setbox\@BILD=\vbox{\box\@BILD\vspace{-5pt}% + \hbox{\hspace{\fboxsep}\box\@TEXT}% + \vspace{4pt}}% + \fi% + \@tfor\@tempa := #5\do{% + \if\@tempa f\setbox\@BILD=\hbox{\Rahmen(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa s\setbox\@BILD=\hbox{\Schatten(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa o\setbox\@BILD=\hbox{\Oval(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa d\setbox\@BILD=\hbox{\Strich(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa x\setbox\@BILD=\hbox{\Kasten(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa l\c@pos=1\fi% + \if\@tempa r\c@pos=2\fi% + }% + \ifnum\c@piccaption=1% + \make@piccaption% + \advance\d@hoehe\ht\@TEXT\advance\d@hoehe\dp\@TEXT% + \c@hoehe=\d@hoehe\divide\c@hoehe by65536% + \setbox\@BILD=\vbox{\box\@BILD\vspace{-5pt}\hbox{\box\@TEXT}\vspace{4pt}}% + \fi% + \ifodd\count0\c@picpos=0\else\c@picpos=\@changemode\fi% + \pagetotal=\the\pagetotal% + \d@tmp=\pagegoal\advance\d@tmp by-\pagetotal\advance\d@tmp by-\baselineskip% + \ifdim\d@hoehe>\d@tmp% + \vskip 0pt plus\d@hoehe\relax\pagebreak[3]\vskip 0pt plus-\d@hoehe\relax% + \ifnum\c@picpos=1\c@picpos=0\else\c@picpos=\@changemode\fi% + \fi% + \ifnum\c@picpos=1\ifnum\c@pos=1\c@pos=2\else\c@pos=1\fi\fi% + \ifnum\@listdepth>0 + \@listtrue\parshape 0% + \advance\hsize -\rightmargin% + \d@leftskip \leftskip% + \leftskip \@totalleftmargin% + \if@inlabel\rule{\linewidth}{0pt}\vskip-\baselineskip\relax\fi% + \else\@listfalse\medskip% + \fi% + \if@list\d@tmpa=\linewidth\else\d@tmpa=\hsize\fi% + \ifnum\c@piccaption=3% + \make@piccaption% + \d@tmp\ht\@TEXT\advance\d@tmp\dp\@TEXT% + \ifdim\d@hoehe>\d@tmp% + \setbox\@TEXT=\vbox to\d@hoehe{\vfill\box\@TEXT\vspace{.2\baselineskip}\vfill}% + \else% + \setbox\@BILD=\vbox to\d@tmp{\vfill\box\@BILD\vfill}% + \d@hoehe\d@tmp% + \fi% + \fi% + \ifnum\c@piccaption=4% + \make@piccaption% + \d@tmp\ht\@TEXT\advance\d@tmp\dp\@TEXT% + \setbox\@TEXT=\vbox to\d@hoehe{\vspace{-10pt}\box\@TEXT\vfil}% + \advance\d@hoehe-\d@tmp% + \fi% + \ifnum\c@pos=1\d@tmpa=0pt% + \ifnum\c@piccaption>2% + \setbox\@BILD=\hbox{\box\@BILD\hspace{\d@pichskip}\hbox{\box\@TEXT}}% + \fi% + \else\advance\d@tmpa by-\wd\@BILD\d@breite=-\d@breite% + \ifnum\c@piccaption>2% + \d@tmpa=0pt% + \setbox\@BILD=\hbox{\hbox{\box\@TEXT}\hspace{\d@pichskip}\box\@BILD}% + \fi% + \fi% + \p@getot@l\the\pagetotal% + \d@bskip\d@hoehe\advance\d@bskip by\parskip\advance\d@bskip by.3\baselineskip% + {\noindent\hspace*{\d@tmpa}\relax% + \box\@BILD\nopagebreak\vskip-\d@bskip\relax\nopagebreak}% + \d@tmp=-\d@hoehe\divide\d@tmp by\baselineskip% + \c@zeilen=\d@tmp\advance\c@zeilen by-1% + \ifdim\d@breite<0pt\advance\d@breite by-\d@pichskip% + \else\advance\d@breite by\d@pichskip% + \fi% + \hangindent=\d@breite% + \hangafter=\c@zeilen% + \let\par=\x@par% + \ifnum\c@piccaption=3% + \hangindent0pt\hangafter1\let\par=\old@par% + \vskip\d@hoehe\vskip.2\baselineskip% + \fi% + \c@piccaption=0% +} + + + + +\newdimen\ptoti +\newdimen\ptotii +\def\x@par{% + \ptoti\pagetotal% + \old@par% + \ptotii\pagetotal% + \ifdim\ptoti=\ptotii% + \d@tmp\d@hoehe% + \else% + \d@tmp\baselineskip% + \multiply\d@tmp by\prevgraf% + \advance\d@tmp by\parskip% + \global\advance\d@hoehe by-\d@tmp\d@tmp=\d@hoehe% + \fi% + \ifdim\d@hoehe>0pt% + \divide\d@tmp by\baselineskip\c@zeilen=-\d@tmp\advance\c@zeilen by-1% + \c@zeilen=\the\c@zeilen% + \else\c@zeilen=0 + \fi + \ifnum\c@zeilen<0\hangafter=\c@zeilen\hangindent=\d@breite% + \else\let\par=\old@par% + \hangindent 0pt% + \leftskip \d@leftskip% + \if@list\parshape \@ne \@totalleftmargin \linewidth% + \advance\hsize \rightmargin% + \fi% + \fi% +} + + +\def\picskip#1{% + \let\par=\old@par% + \par% + \pagetotal\the\pagetotal% + \c@tmp=#1\relax% + \ifnum\c@tmp=0% + \d@tmp\baselineskip\multiply\d@tmp by\prevgraf\advance\d@tmp\parskip% + \ifdim\p@getot@l<\pagetotal + \advance\d@hoehe by-\d@tmp\advance\d@hoehe by1ex% + \ifdim\d@hoehe>0pt\vspace*{\d@hoehe}\fi% + \fi% + \ifdim\p@getot@l=\pagetotal% + \advance\d@hoehe by-\d@tmp\advance\d@hoehe by1ex% + \ifdim\d@hoehe>0pt\vspace*{\d@hoehe}\fi% + \fi% + \else\hangafter=-\c@tmp\hangindent=\d@breite% + \fi% + \leftskip \d@leftskip% + \if@list\parshape \@ne \@totalleftmargin \linewidth% + \advance\hsize \rightmargin% + \fi% +} + + + + + + +\def\hpic{% + \@ifnextchar ({\ihpic}{\ihpic(0pt,0pt)} +} +\def\ihpic(#1,#2){% + \@ifnextchar ({\@offsettrue\iihpic(#1,#2)}% + {\@offsetfalse\iihpic(#1,#2)(0pt,0pt)} +} +\def\iihpic(#1,#2)(#3,#4){% + \@ifnextchar [{\iiihpic(#1,#2)(#3,#4)}{\iiihpic(#1,#2)(#3,#4)[l]} +} +\def\iiihpic(#1,#2)(#3,#4)[#5]{% + \@ifnextchar [{\ivhpic(#1,#2)(#3,#4)[#5]}{\ivhpic(#1,#2)(#3,#4)[#5][]} +} +\def\ivhpic(#1,#2)(#3,#4)[#5][#6]#7{% + \setbox\@BILD=\hbox{#7}% + \d@breite=#1\d@breite=\the\d@breite% + \ifdim\d@breite=0pt\d@breite=\wd\@BILD\fi% + \c@breite=\d@breite\divide\c@breite by65536% + \d@hoehe=#2\d@hoehe=\the\d@hoehe% + \ifdim\d@hoehe=0pt\d@hoehe=\ht\@BILD\advance\d@hoehe by\dp\@BILD\fi% + \c@hoehe=\d@hoehe\divide\c@hoehe by65536% + \d@xoff=#3\c@xoff=\d@xoff\divide\c@xoff by65536% + \d@yoff=\d@hoehe% + \advance\d@yoff by-#4\c@yoff=\d@yoff\divide\c@yoff by65536% + \c@pos=0\d@tmpa=\parindent\parindent=0pt\unitlength1pt% + \if@offset + \setbox\@BILD=\hbox{% + \begin{picture}(\c@breite,\c@hoehe)% + \put(0,0){\makebox(\c@breite,\c@hoehe){}}% + \put(\c@xoff,\c@yoff){\box\@BILD}% + \end{picture}% + }% + \else% + \setbox\@BILD=\hbox{% + \begin{picture}(\c@breite,\c@hoehe)% + \put(0,0){\makebox(\c@breite,\c@hoehe)[#6]{\box\@BILD}}% + \end{picture}% + }% + \fi% + \@tfor\@tempa := #5\do{% + \if\@tempa f\setbox\@BILD=\hbox{\Rahmen(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa s\setbox\@BILD=\hbox{\Schatten(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa o\setbox\@BILD=\hbox{\Oval(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa d\setbox\@BILD=\hbox{\Strich(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa x\setbox\@BILD=\hbox{\Kasten(\c@breite,\c@hoehe){\box\@BILD}}\fi% + \if\@tempa t\c@pos=1\fi% + \if\@tempa b\c@pos=2\fi% + }% + \ifnum\c@pos=0\parbox{\d@breite}{\makebox[0cm]{}\\\box\@BILD\smallskip}\fi% + \ifnum\c@pos=1\parbox[t]{\d@breite}{\makebox[0cm]{}\\\box\@BILD\smallskip}\fi% + \ifnum\c@pos=2\parbox[b]{\d@breite}{\makebox[0cm]{}\\\box\@BILD\smallskip}\fi% + \parindent=\d@tmpa% +} + + + + + + +\def\Rahmen(#1,#2)#3{% + \c@whole=\@wholewidth\divide\c@whole by65536% + \c@half=\@halfwidth\divide\c@half by65536% + \c@tmpa=#1\advance\c@tmpa by\c@whole\advance\c@tmpa by\c@whole% + \c@tmpb=#2\advance\c@tmpb by\c@whole\advance\c@tmpb by\c@whole% + \begin{picture}(\c@tmpa,\c@tmpb)% + \put(\c@whole,\c@half){\framebox(#1,#2){#3}}% + \end{picture}% + \global\advance\d@breite by2\@wholewidth% + \global\advance\d@hoehe by2\@wholewidth% +} + + +\def\Schatten(#1,#2)#3{% + \c@whole=\@wholewidth\divide\c@whole by65536% + \c@half=\@halfwidth\divide\c@half by65536% + \c@shad=\d@shad\divide\c@shad by65536% + \c@tmp=\c@whole\advance\c@tmp by\c@whole\c@tmpd=\c@tmp% + \advance\c@tmp by\c@shad% + \advance\c@tmpd by#1% + \advance\c@half by\c@shad% + \c@tmpa=#1\advance\c@tmpa by\c@tmp% + \c@tmpb=#2\advance\c@tmpb by\c@tmp% + \begin{picture}(\c@tmpa,\c@tmpb)% + \put(\c@whole,\c@half){\framebox(#1,#2){#3}}% + \put(\c@shad,0){\rule{\c@tmpd pt}{\c@shad pt}}% + \put(\c@tmpd,0){\rule{\c@shad pt}{#2 pt}}% + \end{picture}% + \global\advance\d@breite by2\@wholewidth\global\advance\d@breite by\d@shad% + \global\advance\d@hoehe by2\@wholewidth\global\advance\d@hoehe by\d@shad% +} + + +\def\Oval(#1,#2)#3{% + \@wholewidth=0.4pt% + \c@tmpa=\the#1\divide\c@tmpa by2% + \c@tmpb=\the#2\divide\c@tmpb by2% + \begin{picture}(#1,#2)% + \put(\c@tmpa,\c@tmpb){\oval(#1,#2)}% + \put(0.4,0.4){#3}% + \end{picture}% + \global\advance\d@breite by1pt\global\advance\d@hoehe by1pt% +} + + +\def\Strich(#1,#2)#3{% + \c@whole=\@wholewidth\divide\c@whole by65536% + \c@half=\@halfwidth\divide\c@half by65536% + \c@dash=\d@dash\divide\c@dash by65536% + \c@tmp=\c@whole\advance\c@tmp by\c@whole% + \c@tmpa=#1\advance\c@tmpa by\c@tmp% + \c@tmpb=#2\advance\c@tmpb by\c@tmp% + \c@tmpc=#1\advance\c@tmpc by\c@whole% + \c@tmpd=#2\advance\c@tmpd by\c@whole% + \begin{picture}(\c@tmpa,\c@tmpb)% + \put(\c@half,\c@half){\dashbox{\c@dash}(\c@tmpc,\c@tmpd){#3}}% + \end{picture}% + \global\advance\d@breite by2\@wholewidth% + \global\advance\d@hoehe by2\@wholewidth% +} + + +\def\Kasten(#1,#2)#3{% + \@wholewidth=0.4pt% + \c@boxl=\d@boxl\divide\c@boxl by65536\c@boxl=\the\c@boxl% + \c@tmpa=#1\advance\c@tmpa by\c@boxl% + \c@tmpb=#2\advance\c@tmpb by\c@boxl% + \c@tmp=#2% + \begin{picture}(\c@tmpa,\c@tmpb)% + \put(0,\c@boxl){\framebox(#1,#2){#3}}% + \put(\c@boxl,0){\line(-1,1){\c@boxl}}% + \put(\c@boxl,0){\line(1,0){#1}\line(-1,1){\c@boxl}}% + \put(\c@boxl,0){\put(#1,0){\line(0,1){\c@tmp}% + \put(0,\c@tmp){\line(-1,1){\c@boxl}}}}% + \end{picture}% + \global\advance\d@breite by\d@boxl% + \global\advance\d@hoehe by\d@boxl% +} + + + + + +\newbox\env@box% +\newdimen\d@envdp +\newcount\c@hsize +\newcount\c@envdp +\newdimen\d@envb + +\long\def\frameenv{\@ifnextchar [{\@frameenv}{\@frameenv[\textwidth]}} +\long\def\@frameenv[#1]{% + \hsiz@=\textwidth \textwidth=#1 \d@envb=#1 + \advance\textwidth by-2\@wholewidth + \advance\textwidth by-2\fboxsep + \hsize=\textwidth \linewidth=\textwidth + \setbox\env@box=\vbox\bgroup}% +\def\endframeenv{% + \egroup% + \hsize=\hsiz@ \textwidth=\hsiz@ \linewidth=\hsiz@ + \c@breite=\d@envb \divide\c@breite by65536 + \advance\d@envb by-2\@wholewidth + \c@hsize=\d@envb \divide\c@hsize by65536% + \d@envdp=\dp\env@box \advance\d@envdp by\ht\env@box% + \advance\d@envdp by2\fboxsep% + \d@hoehe=\d@envdp \advance\d@hoehe by2\@wholewidth + \c@hoehe=\d@hoehe \divide\c@hoehe by65536 + \c@envdp=\d@envdp \divide\c@envdp by65536% + \c@tmp=\@wholewidth \divide\c@tmp by65536 + \vskip\@wholewidth% + \unitlength 1pt\noindent% + \begin{picture}(\c@breite,\c@hoehe)(0,0) + \put(\c@tmp,\c@tmp){\framebox(\c@hsize,\c@envdp){\box\env@box}} + \end{picture}% +} + + + +\long\def\shadowenv{\@ifnextchar [{\@shadowenv}{\@shadowenv[\textwidth]}} +\long\def\@shadowenv[#1]{% + \hsiz@=\textwidth \textwidth=#1 \d@envb=#1 + \advance\textwidth by-2\@wholewidth + \advance\textwidth by-2\fboxsep + \advance\textwidth by-\d@shad% + \hsize=\textwidth \linewidth=\textwidth + \setbox\env@box=\vbox\bgroup}% +\def\endshadowenv{% + \egroup + \hsize=\hsiz@ \textwidth=\hsiz@ \linewidth=\hsiz@ + \d@tmpa=\d@envb + \c@breite=\d@envb \divide\c@breite by65536 + \advance\d@envb by-2\@wholewidth \advance\d@envb by-\d@shad + \c@hsize=\d@envb \divide\c@hsize by65536% + \d@envdp=\dp\env@box \advance\d@envdp by\ht\env@box% + \advance\d@envdp by2\fboxsep% + \c@envdp=\d@envdp \divide\c@envdp by65536% + \d@hoehe=\d@envdp + \advance\d@hoehe by2\@wholewidth \advance\d@hoehe by\d@shad + \c@hoehe=\d@hoehe \divide\c@hoehe by65536 + \c@shad =\d@shad \divide\c@shad by65536 + \c@tmp=\@wholewidth \divide\c@tmp by65536 + \advance\d@tmpa by-2\d@shad + \c@xoff =\d@tmpa \divide\c@xoff by65536 + \advance\c@xoff by\c@shad \advance\c@xoff by-1 + \advance\d@envdp by\@wholewidth + \vskip\@halfwidth + \unitlength 1pt\noindent% + \begin{picture}(\c@breite,\c@hoehe)(0,0) + \put(\c@tmp,\c@shad){\framebox(\c@hsize,\c@envdp){\box\env@box}} + \put(\c@shad,0){\rule{\d@tmpa}{\d@shad}}% + \put(\c@xoff,0){\rule{\d@shad}{\d@envdp}}% + \end{picture}% + \vskip\@halfwidth +} + + +\long\def\dashenv{\@ifnextchar [{\@dashenv}{\@dashenv[\textwidth]}} +\long\def\@dashenv[#1]{% + \hsiz@=\textwidth \textwidth=#1 \d@envb=#1 + \advance\textwidth by-2\@wholewidth \advance\textwidth by-2\fboxsep + \hsize=\textwidth \linewidth=\textwidth + \setbox\env@box=\vbox\bgroup}% +\long\def\enddashenv{% + \egroup + \hsize=\hsiz@ \textwidth=\hsiz@ \linewidth=\hsiz@ + \c@breite=\d@envb \divide\c@breite by65536 + \advance\d@envb by-\@wholewidth + \c@hsize=\d@envb \divide\c@hsize by65536% + \d@envdp=\dp\env@box \advance\d@envdp by\ht\env@box% + \advance\d@envdp by2\fboxsep% + \advance\d@envdp by\@wholewidth + \d@hoehe=\d@envdp \advance\d@hoehe by2\@wholewidth + \c@hoehe=\d@hoehe \divide\c@hoehe by65536 + \c@envdp=\d@envdp \divide\c@envdp by65536% + \c@dash=\d@dash \divide\c@dash by65536% + \c@whole=\@wholewidth \divide\c@whole by65536 + \c@half=\@halfwidth \divide\c@half by 65536 + \noindent\unitlength 1pt + \begin{picture}(\c@breite,\c@hoehe)(0,0) + \put(\c@half,\c@whole){\dashbox{\c@dash}(\c@hsize,\c@envdp){\box\env@box}} + \end{picture}% +} + + +\long\def\ovalenv{\@ifnextchar [{\@ovalenv}{\@ovalenv[\textwidth]}}% +\long\def\@ovalenv[#1]{% + \hsiz@=\textwidth \textwidth=#1 \d@envb=#1 + \advance\textwidth by-4\fboxsep + \hsize=\textwidth \linewidth=\textwidth + \setbox\env@box=\vbox\bgroup}% +\long\def\endovalenv{% + \egroup + \hsize=\hsiz@ \textwidth=\hsiz@ \linewidth=\hsiz@ + \@wholewidth=0.4pt + \c@breite=\d@envb \divide\c@breite by65536 + \advance\d@envb by-2\@wholewidth + \c@hsize=\d@envb \divide\c@hsize by65536% + \d@envdp=\dp\env@box \advance\d@envdp by\ht\env@box% + \advance\d@envdp by4\fboxsep% + \c@envdp=\d@envdp \divide\c@envdp by65536% + \d@hoehe=\d@envdp \advance\d@hoehe by2\@wholewidth + \c@hoehe=\d@hoehe \divide\c@hoehe by65536 + \c@tmpa=\c@hsize \divide\c@tmpa by2% + \c@tmpb=\c@envdp \divide\c@tmpb by2% + \d@tmpa=2\fboxsep \advance\d@tmpa by\@wholewidth + \c@xoff=\d@tmpa \divide\c@xoff by65536% + \advance\d@tmpa by\dp\env@box + \c@yoff=\d@tmpa \divide\c@yoff by65536% + \unitlength 1pt\noindent + \begin{picture}(\c@breite,\c@hoehe)(0,0) + \put(\c@tmpa,\c@tmpb){\oval(\c@hsize,\c@envdp)} + \put(\c@xoff,\c@yoff){\box\env@box}% + \end{picture}% +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/soto.bib Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,73 @@ +@misc{cbc-gcc, + title = {Hoare Logic - 並列信頼研 mercurial repository}, + howpublished = {\url{http://www.cr.ie.u-ryukyu.ac.jp/hg/Members/ryokka/HoareLogic/}}, + note = {Accessed: 2020/09/10},} + + +@mastersthesis{ryokka-master, + author = "外間政尊", + title = "Continuation based C での Hoare Logic を用いた仕様記述と検証", + school = "琉球大学 大学院理工学研究科 情報工学専攻", + year = "2019" +} + +@article{hoare, + author = {Hoare, C. A. R.}, + title = {An Axiomatic Basis for Computer Programming}, + year = {1969}, + issue_date = {October 1969}, + publisher = {Association for Computing Machinery}, + address = {New York, NY, USA}, + volume = {12}, + number = {10}, + issn = {0001-0782}, + url = {https://doi.org/10.1145/363235.363259}, + doi = {10.1145/363235.363259}, + journal = {Commun. ACM}, + month = oct, + pages = {576–580}, + numpages = {5}, + keywords = {programming language design, theory of programming’ proofs of programs, machine-independent programming, program documentation, axiomatic method, formal language definition} +} + +@misc{agda-wiki, + title = {The Agda wiki}, + howpublished = {\url{http://wiki.portal.chalmers.se/agda/pmwiki.php}}, + note = {Accessed: 2020/09/10}, +} + +@misc{agda-documentation, + title = {Welcome to Agda’s documentation! — Agda latest documentation}, + howpublished = {\url{http://agda.readthedocs.io/en/latest/}}, + note = {Accessed: 2020/09/10}, +} + +@book{Stump:2016:VFP:2841316, + author = {Stump, Aaron}, + title = {Verified Functional Programming in Agda}, + year = {2016}, + isbn = {978-1-97000-127-3}, + publisher = {Association for Computing Machinery and Morgan \&\#38; Claypool}, + address = {New York, NY, USA}, +} + +@mastersthesis{atton-master, + author = "比嘉健太", + title = "メタ計算を用いた Continuation based C の検証手法", + school = "琉球大学 大学院理工学研究科 情報工学専攻", + year = "2017" +} + +@mastersthesis{utah-master, + author = "徳森海斗", + title = "LLVM Clang 上の Continuation based C コンパイラ の改良", + school = "琉球大学 大学院理工学研究科 情報工学専攻", + year = "2016" +} + +@misc{rbtree, + title={データ構造と基本アルゴリズム}, + author={渡邉}, + year={2000}, + publisher={共立出版} +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaBasics.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +module AgdaBasics where
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaBasics.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +module AgdaBasics where
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaBool.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +data Bool : Set where + true : Bool + false : Bool
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaBool.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +data Bool : Set where + true : Bool + false : Bool
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaDebug.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,32 @@ +open import Level renaming (suc to succ ; zero to Zero ) + +module AgdaDebug where + +open import stack + +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Data.Nat +open import Function + + +open SingleLinkedStack +open Stack + +testStack07 : {m : Level } -> Maybe (Element ℕ) +testStack07 = pushSingleLinkedStack emptySingleLinkedStack 1 (\s -> pushSingleLinkedStack s 2 (\s -> top s)) + +testStack08 = pushSingleLinkedStack emptySingleLinkedStack 1 + $ \s -> pushSingleLinkedStack s 2 + $ \s -> pushSingleLinkedStack s 3 + $ \s -> pushSingleLinkedStack s 4 + $ \s -> pushSingleLinkedStack s 5 + $ \s -> top s + + +testStack10 = pushStack emptySingleLinkedStack 1 + $ \s -> pushStack 2 + $ \s -> pushStack 3 + $ \s -> pushStack 4 + $ \s -> pushStack 5 + $ \s -> top s
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaDebug.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,32 @@ +open import Level renaming (suc to succ ; zero to Zero ) + +module AgdaDebug where + +open import stack + +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Data.Nat +open import Function + + +open SingleLinkedStack +open Stack + +testStack07 : {m : Level } @$\rightarrow$@ Maybe (Element @$\mathbb{N}$@) +testStack07 = pushSingleLinkedStack emptySingleLinkedStack 1 (\s @$\rightarrow$@ pushSingleLinkedStack s 2 (\s @$\rightarrow$@ top s)) + +testStack08 = pushSingleLinkedStack emptySingleLinkedStack 1 + $ \s @$\rightarrow$@ pushSingleLinkedStack s 2 + $ \s @$\rightarrow$@ pushSingleLinkedStack s 3 + $ \s @$\rightarrow$@ pushSingleLinkedStack s 4 + $ \s @$\rightarrow$@ pushSingleLinkedStack s 5 + $ \s @$\rightarrow$@ top s + + +testStack10 = pushStack emptySingleLinkedStack 1 + $ \s @$\rightarrow$@ pushStack 2 + $ \s @$\rightarrow$@ pushStack 3 + $ \s @$\rightarrow$@ pushStack 4 + $ \s @$\rightarrow$@ pushStack 5 + $ \s @$\rightarrow$@ top s
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaElem.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +elem : {A : Set} {{eqA : Eq A}} → A → List A → Bool +elem {{eqA}} x (y ∷ xs) = (Eq._==_ eqA x y) || (elem {{eqA}} x xs) +elem x [] = false
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaElem.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +elem : {A : Set} {{eqA : Eq A}} @$\rightarrow$@ A @$\rightarrow$@ List A @$\rightarrow$@ Bool +elem {{eqA}} x (y @$\text{::}$@ xs) = (Eq._==_ eqA x y) || (elem {{eqA}} x xs) +elem x [] = false
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaElemApply.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +listHas4 : Bool +listHas4 = elem 4 (3 ∷ 2 ∷ 5 ∷ 4 ∷ []) -- true +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaElemApply.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +listHas4 : Bool +listHas4 = elem 4 (3 @$\text{::}$@ 2 @$\text{::}$@ 5 @$\text{::}$@ 4 @$\text{::}$@ []) -- true +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaFunction.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +f : Bool -> Bool +f x = true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaFunction.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +f : Bool @$\rightarrow$@ Bool +f x = true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaId.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +identity : (A : Set) -> A -> A +identity A x = x + +identity-zero : Nat +identity-zero = identity Nat zero
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaId.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +identity : (A : Set) @$\rightarrow$@ A @$\rightarrow$@ A +identity A x = x + +identity-zero : Nat +identity-zero = identity Nat zero
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaImplicitId.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ +id : {A : Set} -> A -> A +id x = x + +id-zero : Nat +id-zero = id zero + +id' : {A : Set} -> A -> A +id' {A} x = x + +id-true : Bool +id-true = id {Bool} true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaImplicitId.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ +id : {A : Set} @$\rightarrow$@ A @$\rightarrow$@ A +id x = x + +id-zero : Nat +id-zero = id zero + +id' : {A : Set} @$\rightarrow$@ A @$\rightarrow$@ A +id' {A} x = x + +id-true : Bool +id-true = id {Bool} true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaImport.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +import Data.Nat -- import module +import Data.Bool as B -- renamed module +import Data.List using (head) -- import Data.head function +import Level renaming (suc to S) -- import module with rename suc to S +import Data.String hiding (_++_) -- import module without _++_ +open import Data.List -- import and expand Data.List
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaImport.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +import Data.Nat -- import module +import Data.Bool as B -- renamed module +import Data.List using (head) -- import Data.head function +import Level renaming (suc to S) -- import module with rename suc to S +import Data.String hiding (_++_) -- import module without _++_ +open import Data.List -- import and expand Data.List
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaInstance.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +_==Nat_ : Nat -> Nat -> Bool +zero ==Nat zero = true +(suc n) ==Nat zero = false +zero ==Nat (suc m) = false +(suc n) ==Nat (suc m) = n ==Nat m + +instance + natHas== : Eq Nat + natHas== = record { _==_ = _==Nat_}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaInstance.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +_==Nat_ : Nat @$\rightarrow$@ Nat @$\rightarrow$@ Bool +zero ==Nat zero = true +(suc n) ==Nat zero = false +zero ==Nat (suc m) = false +(suc n) ==Nat (suc m) = n ==Nat m + +instance + natHas== : Eq Nat + natHas== = record { _==_ = _==Nat_}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaInterface.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +record StackMethods {n m : Level } (a : Set n ) {t : Set m }(stackImpl : Set n ) : Set (m Level.⊔ n) where + field + push : stackImpl -> a -> (stackImpl -> t) -> t + pop : stackImpl -> (stackImpl -> Maybe a -> t) -> t +open StackMethods + +record Stack {n m : Level } (a : Set n ) {t : Set m } (si : Set n ) : Set (m Level.⊔ n) where + field + stack : si + stackMethods : StackMethods {n} {m} a {t} si + pushStack : a -> (Stack a si -> t) -> t + pushStack d next = push (stackMethods ) (stack ) d (\s1 -> next (record {stack = s1 ; stackMethods = stackMethods } )) + popStack : (Stack a si -> Maybe a -> t) -> t + popStack next = pop (stackMethods ) (stack ) (\s1 d1 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 ) +open Stack
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaInterface.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +record StackMethods {n m : Level } (a : Set n ) {t : Set m }(stackImpl : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + push : stackImpl @$\rightarrow$@ a @$\rightarrow$@ (stackImpl @$\rightarrow$@ t) @$\rightarrow$@ t + pop : stackImpl @$\rightarrow$@ (stackImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t +open StackMethods + +record Stack {n m : Level } (a : Set n ) {t : Set m } (si : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + stack : si + stackMethods : StackMethods {n} {m} a {t} si + pushStack : a @$\rightarrow$@ (Stack a si @$\rightarrow$@ t) @$\rightarrow$@ t + pushStack d next = push (stackMethods ) (stack ) d (\s1 @$\rightarrow$@ next (record {stack = s1 ; stackMethods = stackMethods } )) + popStack : (Stack a si @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + popStack next = pop (stackMethods ) (stack ) (\s1 d1 @$\rightarrow$@ next (record {stack = s1 ; stackMethods = stackMethods }) d1 ) +open Stack
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaLambda.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ ++1 : ℕ → ℕ ++1 n = suc n -- not use lambda + +λ+1 : ℕ → ℕ +λ+1 = (\n -> suc n) -- use lambda
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaLambda.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ ++1 : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ ++1 n = suc n -- not use lambda + +@$\lambda$@+1 : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ +@$\lambda$@+1 = (\n @$\rightarrow$@ suc n) -- use lambda
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaModusPonens.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +f : {A B C : Set} -> ((A -> B) × (B -> C)) -> (A -> C) +f = \p x -> (snd p) ((fst p) x)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaModusPonens.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +f : {A B C : Set} @$\rightarrow$@ ((A @$\rightarrow$@ B) @$\times$@ (B @$\rightarrow$@ C)) @$\rightarrow$@ (A @$\rightarrow$@ C) +f = \p x @$\rightarrow$@ (snd p) ((fst p) x)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaNPushNPop.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,13 @@ +n-push : {m : Meta} {{_ : M.DataSegment Meta}} (n : ℕ) -> M.CodeSegment Meta Meta +n-push {{mm}} (zero) = M.cs {{mm}} {{mm}} id +n-push {m} {{mm}} (suc n) = M.cs {{mm}} {{mm}} (\m -> M.exec {{mm}} {{mm}} (n-push {m} {{mm}} n) (pushOnce m)) + +n-pop : {m : Meta} {{_ : M.DataSegment Meta}} (n : ℕ) -> M.CodeSegment Meta Meta +n-pop {{mm}} (zero) = M.cs {{mm}} {{mm}} id +n-pop {m} {{mm}} (suc n) = M.cs {{mm}} {{mm}} (\m -> M.exec {{mm}} {{mm}} (n-pop {m} {{mm}} n) (popOnce m)) + +pop-n-push-type : ℕ -> ℕ -> ℕ -> SingleLinkedStack ℕ -> Set₁ +pop-n-push-type n cn ce s = M.exec (M.csComp {meta} (M.cs popOnce) (n-push {meta} (suc n))) meta + ≡ M.exec (n-push {meta} n) meta + where + meta = id-meta cn ce s
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaNPushNPop.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,13 @@ +n-push : {m : Meta} {{_ : M.DataSegment Meta}} (n : @$\mathbb{N}$@) @$\rightarrow$@ M.CodeSegment Meta Meta +n-push {{mm}} (zero) = M.cs {{mm}} {{mm}} id +n-push {m} {{mm}} (suc n) = M.cs {{mm}} {{mm}} (\m @$\rightarrow$@ M.exec {{mm}} {{mm}} (n-push {m} {{mm}} n) (pushOnce m)) + +n-pop : {m : Meta} {{_ : M.DataSegment Meta}} (n : @$\mathbb{N}$@) @$\rightarrow$@ M.CodeSegment Meta Meta +n-pop {{mm}} (zero) = M.cs {{mm}} {{mm}} id +n-pop {m} {{mm}} (suc n) = M.cs {{mm}} {{mm}} (\m @$\rightarrow$@ M.exec {{mm}} {{mm}} (n-pop {m} {{mm}} n) (popOnce m)) + +pop-n-push-type : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack @$\mathbb{N}$@ @$\rightarrow$@ Set@$\_{1}$@ +pop-n-push-type n cn ce s = M.exec (M.csComp {meta} (M.cs popOnce) (n-push {meta} (suc n))) meta + @$\equiv$@ M.exec (n-push {meta} n) meta + where + meta = id-meta cn ce s
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaNPushNPopProof.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,58 @@ +pop-n-push-type : ℕ -> ℕ -> ℕ -> SingleLinkedStack ℕ -> Set₁ +pop-n-push-type n cn ce s = M.exec (M.csComp (M.cs popOnce) (n-push (suc n))) meta + ≡ M.exec (n-push n) meta + where + meta = id-meta cn ce s + +pop-n-push : (n cn ce : ℕ) -> (s : SingleLinkedStack ℕ) -> pop-n-push-type n cn ce s +pop-n-push zero cn ce s = refl +pop-n-push (suc n) cn ce s = begin + M.exec (M.csComp (M.cs popOnce) (n-push (suc (suc n)))) (id-meta cn ce s) + ≡⟨ refl ⟩ + M.exec (M.csComp (M.cs popOnce) (M.csComp (n-push (suc n)) (M.cs pushOnce))) (id-meta cn ce s) + ≡⟨ exec-comp (M.cs popOnce) (M.csComp (n-push (suc n)) (M.cs pushOnce)) (id-meta cn ce s) ⟩ + M.exec (M.cs popOnce) (M.exec (M.csComp (n-push (suc n)) (M.cs pushOnce)) (id-meta cn ce s)) + ≡⟨ cong (\x -> M.exec (M.cs popOnce) x) (exec-comp (n-push (suc n)) (M.cs pushOnce) (id-meta cn ce s)) ⟩ + M.exec (M.cs popOnce) (M.exec (n-push (suc n))(M.exec (M.cs pushOnce) (id-meta cn ce s))) + ≡⟨ refl ⟩ + M.exec (M.cs popOnce) (M.exec (n-push (suc n)) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}))) + ≡⟨ sym (exec-comp (M.cs popOnce) (n-push (suc n)) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}))) ⟩ + M.exec (M.csComp (M.cs popOnce) (n-push (suc n))) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})) + ≡⟨ pop-n-push n cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}) ⟩ + M.exec (n-push n) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})) + ≡⟨ refl ⟩ + M.exec (n-push n) (pushOnce (id-meta cn ce s)) + ≡⟨ refl ⟩ + M.exec (n-push n) (M.exec (M.cs pushOnce) (id-meta cn ce s)) + ≡⟨ refl ⟩ + M.exec (n-push (suc n)) (id-meta cn ce s) + ∎ + + + +n-push-pop-type : ℕ -> ℕ -> ℕ -> SingleLinkedStack ℕ -> Set₁ +n-push-pop-type n cn ce st = M.exec (M.csComp (n-pop n) (n-push n)) meta ≡ meta + where + meta = id-meta cn ce st + +n-push-pop : (n cn ce : ℕ) -> (s : SingleLinkedStack ℕ) -> n-push-pop-type n cn ce s +n-push-pop zero cn ce s = refl +n-push-pop (suc n) cn ce s = begin + M.exec (M.csComp (n-pop (suc n)) (n-push (suc n))) (id-meta cn ce s) + ≡⟨ refl ⟩ + M.exec (M.csComp (M.cs (\m -> M.exec (n-pop n) (popOnce m))) (n-push (suc n))) (id-meta cn ce s) + ≡⟨ exec-comp (M.cs (\m -> M.exec (n-pop n) (popOnce m))) (n-push (suc n)) (id-meta cn ce s) ⟩ + M.exec (M.cs (\m -> M.exec (n-pop n) (popOnce m))) (M.exec (n-push (suc n)) (id-meta cn ce s)) + ≡⟨ refl ⟩ + M.exec (n-pop n) (popOnce (M.exec (n-push (suc n)) (id-meta cn ce s))) + ≡⟨ refl ⟩ + M.exec (n-pop n) (M.exec (M.cs popOnce) (M.exec (n-push (suc n)) (id-meta cn ce s))) + ≡⟨ cong (\x -> M.exec (n-pop n) x) (sym (exec-comp (M.cs popOnce) (n-push (suc n)) (id-meta cn ce s))) ⟩ + M.exec (n-pop n) (M.exec (M.csComp (M.cs popOnce) (n-push (suc n))) (id-meta cn ce s)) + ≡⟨ cong (\x -> M.exec (n-pop n) x) (pop-n-push n cn ce s) ⟩ + M.exec (n-pop n) (M.exec (n-push n) (id-meta cn ce s)) + ≡⟨ sym (exec-comp (n-pop n) (n-push n) (id-meta cn ce s)) ⟩ + M.exec (M.csComp (n-pop n) (n-push n)) (id-meta cn ce s) + ≡⟨ n-push-pop n cn ce s ⟩ + id-meta cn ce s + ∎
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaNPushNPopProof.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,58 @@ +pop-n-push-type : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack @$\mathbb{N}$@ @$\rightarrow$@ Set@$\_{1}$@ +pop-n-push-type n cn ce s = M.exec (M.csComp (M.cs popOnce) (n-push (suc n))) meta + @$\equiv$@ M.exec (n-push n) meta + where + meta = id-meta cn ce s + +pop-n-push : (n cn ce : @$\mathbb{N}$@) @$\rightarrow$@ (s : SingleLinkedStack @$\mathbb{N}$@) @$\rightarrow$@ pop-n-push-type n cn ce s +pop-n-push zero cn ce s = refl +pop-n-push (suc n) cn ce s = begin + M.exec (M.csComp (M.cs popOnce) (n-push (suc (suc n)))) (id-meta cn ce s) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (M.csComp (M.cs popOnce) (M.csComp (n-push (suc n)) (M.cs pushOnce))) (id-meta cn ce s) + @$\equiv$@@$\langle$@ exec-comp (M.cs popOnce) (M.csComp (n-push (suc n)) (M.cs pushOnce)) (id-meta cn ce s) @$\rangle$@ + M.exec (M.cs popOnce) (M.exec (M.csComp (n-push (suc n)) (M.cs pushOnce)) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ cong (\x @$\rightarrow$@ M.exec (M.cs popOnce) x) (exec-comp (n-push (suc n)) (M.cs pushOnce) (id-meta cn ce s)) @$\rangle$@ + M.exec (M.cs popOnce) (M.exec (n-push (suc n))(M.exec (M.cs pushOnce) (id-meta cn ce s))) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (M.cs popOnce) (M.exec (n-push (suc n)) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}))) + @$\equiv$@@$\langle$@ sym (exec-comp (M.cs popOnce) (n-push (suc n)) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}))) @$\rangle$@ + M.exec (M.csComp (M.cs popOnce) (n-push (suc n))) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})) + @$\equiv$@@$\langle$@ pop-n-push n cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}) @$\rangle$@ + M.exec (n-push n) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-push n) (pushOnce (id-meta cn ce s)) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-push n) (M.exec (M.cs pushOnce) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-push (suc n)) (id-meta cn ce s) + @$\blacksquare$@ + + + +n-push-pop-type : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack @$\mathbb{N}$@ @$\rightarrow$@ Set@$\_{1}$@ +n-push-pop-type n cn ce st = M.exec (M.csComp (n-pop n) (n-push n)) meta @$\equiv$@ meta + where + meta = id-meta cn ce st + +n-push-pop : (n cn ce : @$\mathbb{N}$@) @$\rightarrow$@ (s : SingleLinkedStack @$\mathbb{N}$@) @$\rightarrow$@ n-push-pop-type n cn ce s +n-push-pop zero cn ce s = refl +n-push-pop (suc n) cn ce s = begin + M.exec (M.csComp (n-pop (suc n)) (n-push (suc n))) (id-meta cn ce s) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (M.csComp (M.cs (\m @$\rightarrow$@ M.exec (n-pop n) (popOnce m))) (n-push (suc n))) (id-meta cn ce s) + @$\equiv$@@$\langle$@ exec-comp (M.cs (\m @$\rightarrow$@ M.exec (n-pop n) (popOnce m))) (n-push (suc n)) (id-meta cn ce s) @$\rangle$@ + M.exec (M.cs (\m @$\rightarrow$@ M.exec (n-pop n) (popOnce m))) (M.exec (n-push (suc n)) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-pop n) (popOnce (M.exec (n-push (suc n)) (id-meta cn ce s))) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-pop n) (M.exec (M.cs popOnce) (M.exec (n-push (suc n)) (id-meta cn ce s))) + @$\equiv$@@$\langle$@ cong (\x @$\rightarrow$@ M.exec (n-pop n) x) (sym (exec-comp (M.cs popOnce) (n-push (suc n)) (id-meta cn ce s))) @$\rangle$@ + M.exec (n-pop n) (M.exec (M.csComp (M.cs popOnce) (n-push (suc n))) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ cong (\x @$\rightarrow$@ M.exec (n-pop n) x) (pop-n-push n cn ce s) @$\rangle$@ + M.exec (n-pop n) (M.exec (n-push n) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ sym (exec-comp (n-pop n) (n-push n) (id-meta cn ce s)) @$\rangle$@ + M.exec (M.csComp (n-pop n) (n-push n)) (id-meta cn ce s) + @$\equiv$@@$\langle$@ n-push-pop n cn ce s @$\rangle$@ + id-meta cn ce s + @$\blacksquare$@
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaNat.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +data Nat : Set where + zero : Nat + suc : Nat -> Nat
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaNat.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +data Nat : Set where + zero : Nat + suc : Nat @$\rightarrow$@ Nat
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaNot.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +not : Bool -> Bool +not true = false +not false = true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaNot.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +not : Bool @$\rightarrow$@ Bool +not true = false +not false = true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaParameterizedModule.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +module Sort (A : Set) (_<_ : A -> A -> Bool) where +sort : List A -> List A +sort = -- 実装は省略 ... + +-- Parameterized Module により N.sort や B.sort が可能 +open import Sort Nat Nat._<_ as N +open import Sort Bool Bool._<_ as B
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaParameterizedModule.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +module Sort (A : Set) (_<_ : A @$\rightarrow$@ A @$\rightarrow$@ Bool) where +sort : List A @$\rightarrow$@ List A +sort = -- 実装は省略 ... + +-- Parameterized Module により N.sort や B.sort が可能 +open import Sort Nat Nat._<_ as N +open import Sort Bool Bool._<_ as B
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaPattern.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +not : Bool -> Bool +not false = true +not x = false
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaPattern.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +not : Bool @$\rightarrow$@ Bool +not false = true +not x = false
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaPlus.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +_+_ : Nat -> Nat -> Nat +zero + m = m +suc n + m = suc (n + m)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaPlus.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +_+_ : Nat @$\rightarrow$@ Nat @$\rightarrow$@ Nat +zero + m = m +suc n + m = suc (n + m)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaProduct.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +data _×_ (A B : Set) : Set where + <_,_> : A -> B -> A × B + +fst : {A B : Set} -> A × B -> A +fst < a , _ > = a + +snd : {A B : Set} -> A × B -> B +snd < _ , b > = b
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaProduct.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +data _@$\times$@_ (A B : Set) : Set where + <_,_> : A @$\rightarrow$@ B @$\rightarrow$@ A @$\times$@ B + +fst : {A B : Set} @$\rightarrow$@ A @$\times$@ B @$\rightarrow$@ A +fst < a , _ > = a + +snd : {A B : Set} @$\rightarrow$@ A @$\times$@ B @$\rightarrow$@ B +snd < _ , b > = b
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaProp.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +prop : Bool +prop = true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaProp.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +prop : Bool +prop = true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaPushPop.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,28 @@ +pushSingleLinkedStack : Meta -> Meta +pushSingleLinkedStack m = M.exec (liftMeta n) (record m {stack = (push s e) }) + where + n = Meta.nextCS m + s = Meta.stack m + e = Context.element (Meta.context m) + push : SingleLinkedStack A -> Maybe A -> SingleLinkedStack A + push s nothing = s + push s (just x) = record {top = just (cons x (top s))} + +popSingleLinkedStack : Meta -> Meta +popSingleLinkedStack m = M.exec (liftMeta n) (record m {stack = (st m) ; context = record con {element = (elem m)}}) + where + n = Meta.nextCS m + con = Meta.context m + elem : Meta -> Maybe A + elem record {stack = record { top = (just (cons x _)) }} = just x + elem record {stack = record { top = nothing }} = nothing + st : Meta -> SingleLinkedStack A + st record {stack = record { top = (just (cons _ s)) }} = record {top = s} + st record {stack = record { top = nothing }} = record {top = nothing} + + +pushSingleLinkedStackCS : M.CodeSegment Meta Meta +pushSingleLinkedStackCS = M.cs pushSingleLinkedStack + +popSingleLinkedStackCS : M.CodeSegment Meta Meta +popSingleLinkedStackCS = M.cs popSingleLinkedStack
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaPushPop.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,28 @@ +pushSingleLinkedStack : Meta @$\rightarrow$@ Meta +pushSingleLinkedStack m = M.exec (liftMeta n) (record m {stack = (push s e) }) + where + n = Meta.nextCS m + s = Meta.stack m + e = Context.element (Meta.context m) + push : SingleLinkedStack A @$\rightarrow$@ Maybe A @$\rightarrow$@ SingleLinkedStack A + push s nothing = s + push s (just x) = record {top = just (cons x (top s))} + +popSingleLinkedStack : Meta @$\rightarrow$@ Meta +popSingleLinkedStack m = M.exec (liftMeta n) (record m {stack = (st m) ; context = record con {element = (elem m)}}) + where + n = Meta.nextCS m + con = Meta.context m + elem : Meta @$\rightarrow$@ Maybe A + elem record {stack = record { top = (just (cons x _)) }} = just x + elem record {stack = record { top = nothing }} = nothing + st : Meta @$\rightarrow$@ SingleLinkedStack A + st record {stack = record { top = (just (cons _ s)) }} = record {top = s} + st record {stack = record { top = nothing }} = record {top = nothing} + + +pushSingleLinkedStackCS : M.CodeSegment Meta Meta +pushSingleLinkedStackCS = M.cs pushSingleLinkedStack + +popSingleLinkedStackCS : M.CodeSegment Meta Meta +popSingleLinkedStackCS = M.cs popSingleLinkedStack
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaPushPopProof.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ +id-meta : ℕ -> ℕ -> SingleLinkedStack ℕ -> Meta +id-meta n e s = record { context = record {n = n ; element = just e} + ; nextCS = (N.cs id) ; stack = s} + +push-pop-type : ℕ -> ℕ -> ℕ -> Element ℕ -> Set₁ +push-pop-type n e x s = M.exec (M.csComp {meta} (M.cs popOnce) (M.cs pushOnce)) meta ≡ meta + where + meta = id-meta n e record {top = just (cons x (just s))} + +push-pop : (n e x : ℕ) -> (s : Element ℕ) -> push-pop-type n e x s +push-pop n e x s = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaPushPopProof.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ +id-meta : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack @$\mathbb{N}$@ @$\rightarrow$@ Meta +id-meta n e s = record { context = record {n = n ; element = just e} + ; nextCS = (N.cs id) ; stack = s} + +push-pop-type : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ Element @$\mathbb{N}$@ @$\rightarrow$@ Set@$\_{1}$@ +push-pop-type n e x s = M.exec (M.csComp {meta} (M.cs popOnce) (M.cs pushOnce)) meta @$\equiv$@ meta + where + meta = id-meta n e record {top = just (cons x (just s))} + +push-pop : (n e x : @$\mathbb{N}$@) @$\rightarrow$@ (s : Element @$\mathbb{N}$@) @$\rightarrow$@ push-pop-type n e x s +push-pop n e x s = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaRecord.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +record Point : Set where + field + x : Nat + y : Nat + +makePoint : Nat -> Nat -> Point +makePoint a b = record { x = a ; y = b }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaRecord.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +record Point : Set where + field + x : Nat + y : Nat + +makePoint : Nat @$\rightarrow$@ Nat @$\rightarrow$@ Point +makePoint a b = record { x = a ; y = b }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaRecordProj.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +getX : Point -> Nat +getX p = Point.x p + +getY : Point -> Nat +getY record { x = a ; y = b} = b + +xPlus5 : Point -> Point +xPlus5 p = record p { x = (Point.x p) + 5}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaRecordProj.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +getX : Point @$\rightarrow$@ Nat +getX p = Point.x p + +getY : Point @$\rightarrow$@ Nat +getY record { x = a ; y = b} = b + +xPlus5 : Point @$\rightarrow$@ Point +xPlus5 p = record p { x = (Point.x p) + 5}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaSingleLinkedStack.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,63 @@ +singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} -> StackMethods {n} {m} a {t} (SingleLinkedStack a) +singleLinkedStackSpec = record { +push = pushSingleLinkedStack +; pop = popSingleLinkedStack +; pop2 = pop2SingleLinkedStack +; get = getSingleLinkedStack +; get2 = get2SingleLinkedStack +; clear = clearSingleLinkedStack +} + +createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> Stack {n} {m} a {t} (SingleLinkedStack a) +createSingleLinkedStack = record { +stack = emptySingleLinkedStack ; +stackMethods = singleLinkedStackSpec +} + +-- Implementation + +pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} -> SingleLinkedStack Data -> Data -> (Code : SingleLinkedStack Data -> t) -> t +pushSingleLinkedStack stack datum next = next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + + +popSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> t) -> t +popSingleLinkedStack stack cs with (top stack) +... | Nothing = cs stack Nothing +... | Just d = cs stack1 (Just data1) + where + data1 = datum d + stack1 = record { top = (next d) } + +pop2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t +pop2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) +... | Nothing = cs stack Nothing Nothing +... | Just d = pop2SingleLinkedStack' {n} {m} stack cs + where + pop2SingleLinkedStack' : {n m : Level } {t : Set m } -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t + pop2SingleLinkedStack' stack cs with (next d) + ... | Nothing = cs stack Nothing Nothing + ... | Just d1 = cs (record {top = (next d1)}) (Just (datum d)) (Just (datum d1)) + + +getSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> t) -> t +getSingleLinkedStack stack cs with (top stack) +... | Nothing = cs stack Nothing +... | Just d = cs stack (Just data1) + where + data1 = datum d + +get2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t +get2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) +... | Nothing = cs stack Nothing Nothing +... | Just d = get2SingleLinkedStack' {n} {m} stack cs + where + get2SingleLinkedStack' : {n m : Level} {t : Set m } -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t + get2SingleLinkedStack' stack cs with (next d) + ... | Nothing = cs stack Nothing Nothing + ... | Just d1 = cs stack (Just (datum d)) (Just (datum d1)) + +clearSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (SingleLinkedStack a -> t) -> t +clearSingleLinkedStack stack next = next (record {top = Nothing})
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaSingleLinkedStack.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,63 @@ +singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ StackMethods {n} {m} a {t} (SingleLinkedStack a) +singleLinkedStackSpec = record { +push = pushSingleLinkedStack +; pop = popSingleLinkedStack +; pop2 = pop2SingleLinkedStack +; get = getSingleLinkedStack +; get2 = get2SingleLinkedStack +; clear = clearSingleLinkedStack +} + +createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ Stack {n} {m} a {t} (SingleLinkedStack a) +createSingleLinkedStack = record { +stack = emptySingleLinkedStack ; +stackMethods = singleLinkedStackSpec +} + +-- Implementation + +pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} @$\rightarrow$@ SingleLinkedStack Data @$\rightarrow$@ Data @$\rightarrow$@ (Code : SingleLinkedStack Data @$\rightarrow$@ t) @$\rightarrow$@ t +pushSingleLinkedStack stack datum next = next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + + +popSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t +popSingleLinkedStack stack cs with (top stack) +... | Nothing = cs stack Nothing +... | Just d = cs stack1 (Just data1) + where + data1 = datum d + stack1 = record { top = (next d) } + +pop2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t +pop2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) +... | Nothing = cs stack Nothing Nothing +... | Just d = pop2SingleLinkedStack' {n} {m} stack cs + where + pop2SingleLinkedStack' : {n m : Level } {t : Set m } @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t + pop2SingleLinkedStack' stack cs with (next d) + ... | Nothing = cs stack Nothing Nothing + ... | Just d1 = cs (record {top = (next d1)}) (Just (datum d)) (Just (datum d1)) + + +getSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t +getSingleLinkedStack stack cs with (top stack) +... | Nothing = cs stack Nothing +... | Just d = cs stack (Just data1) + where + data1 = datum d + +get2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t +get2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) +... | Nothing = cs stack Nothing Nothing +... | Just d = get2SingleLinkedStack' {n} {m} stack cs + where + get2SingleLinkedStack' : {n m : Level} {t : Set m } @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t + get2SingleLinkedStack' stack cs with (next d) + ... | Nothing = cs stack Nothing Nothing + ... | Just d1 = cs stack (Just (datum d)) (Just (datum d1)) + +clearSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (SingleLinkedStack a @$\rightarrow$@ t) @$\rightarrow$@ t +clearSingleLinkedStack stack next = next (record {top = Nothing})
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStack.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,13 @@ +data Element (a : Set) : Set where + cons : a -> Maybe (Element a) -> Element a + +datum : {a : Set} -> Element a -> a +datum (cons a _) = a + +next : {a : Set} -> Element a -> Maybe (Element a) +next (cons _ n) = n + +record SingleLinkedStack (a : Set) : Set where + field + top : Maybe (Element a) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStack.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,13 @@ +data Element (a : Set) : Set where + cons : a @$\rightarrow$@ Maybe (Element a) @$\rightarrow$@ Element a + +datum : {a : Set} @$\rightarrow$@ Element a @$\rightarrow$@ a +datum (cons a _) = a + +next : {a : Set} @$\rightarrow$@ Element a @$\rightarrow$@ Maybe (Element a) +next (cons _ n) = n + +record SingleLinkedStack (a : Set) : Set where + field + top : Maybe (Element a) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStackDS.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,17 @@ +record Context : Set where + field + -- fields for stack + element : Maybe A + + +open import subtype Context as N + +record Meta : Set₁ where + field + -- context as set of data segments + context : Context + stack : SingleLinkedStack A + nextCS : N.CodeSegment Context Context + +open import subtype Meta as M +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStackDS.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,17 @@ +record Context : Set where + field + -- fields for stack + element : Maybe A + + +open import subtype Context as N + +record Meta : Set@$\_{1}$@ where + field + -- context as set of data segments + context : Context + stack : SingleLinkedStack A + nextCS : N.CodeSegment Context Context + +open import subtype Meta as M +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStackImpl.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,19 @@ +pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} -> SingleLinkedStack Data -> Data -> (Code : SingleLinkedStack Data -> t) -> t +pushSingleLinkedStack stack datum next = next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + +-- Basic stack implementations are specifications of a Stack + +singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} -> StackMethods {n} {m} a {t} (SingleLinkedStack a) +singleLinkedStackSpec = record { + push = pushSingleLinkedStack + ; pop = popSingleLinkedStack + } + +createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> Stack {n} {m} a {t} (SingleLinkedStack a) +createSingleLinkedStack = record { + stack = emptySingleLinkedStack ; + tackMethods = singleLinkedStackSpec + }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStackImpl.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,19 @@ +pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} @$\rightarrow$@ SingleLinkedStack Data @$\rightarrow$@ Data @$\rightarrow$@ (Code : SingleLinkedStack Data @$\rightarrow$@ t) @$\rightarrow$@ t +pushSingleLinkedStack stack datum next = next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + +-- Basic stack implementations are specifications of a Stack + +singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ StackMethods {n} {m} a {t} (SingleLinkedStack a) +singleLinkedStackSpec = record { + push = pushSingleLinkedStack + ; pop = popSingleLinkedStack + } + +createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ Stack {n} {m} a {t} (SingleLinkedStack a) +createSingleLinkedStack = record { + stack = emptySingleLinkedStack ; + tackMethods = singleLinkedStackSpec + }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStackSomeState.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +stackInSomeState : {l m : Level} {D : Set l} {t : Set m} (s : SingleLinkedStack D) -> Stack {l} {m} D {t} ( SingleLinkedStack D) +stackInSomeState s = record { stack = s ; stackMethods = singleLinkedStackSpec } + +push->push->pop2 : {l : Level} {D : Set l} (x y : D) (s : SingleLinkedStack D) -> pushStack (stackInSomeState s) x (\s1 -> pushStack s1 y (\s2 -> pop2Stack s2 (\s3 y1 x1 -> (Just x ≡ x1) ∧ (Just y ≡ y1)))) +push->push->pop2 {l} {D} x y s = record {pi1 = refl ; pi2 = refl}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStackSomeState.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +stackInSomeState : {l m : Level} {D : Set l} {t : Set m} (s : SingleLinkedStack D) @$\rightarrow$@ Stack {l} {m} D {t} ( SingleLinkedStack D) +stackInSomeState s = record { stack = s ; stackMethods = singleLinkedStackSpec } + +push@$\rightarrow$@push@$\rightarrow$@pop2 : {l : Level} {D : Set l} (x y : D) (s : SingleLinkedStack D) @$\rightarrow$@ pushStack (stackInSomeState s) x (\s1 @$\rightarrow$@ pushStack s1 y (\s2 @$\rightarrow$@ pop2Stack s2 (\s3 y1 x1 @$\rightarrow$@ (Just x @$\equiv$@ x1) @$\wedge$@ (Just y @$\equiv$@ y1)))) +push@$\rightarrow$@push@$\rightarrow$@pop2 {l} {D} x y s = record {pi1 = refl ; pi2 = refl}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStackTest.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,22 @@ +-- after push 1 and 2, pop2 get 1 and 2 + +testStack02 : {m : Level } -> ( Stack ℕ (SingleLinkedStack ℕ) -> Bool {m} ) -> Bool {m} +testStack02 cs = pushStack createSingleLinkedStack 1 (\s -> pushStack s 2 cs) + + +testStack031 : (d1 d2 : ℕ ) -> Bool {Zero} +testStack031 2 1 = True +testStack031 _ _ = False + +testStack032 : (d1 d2 : Maybe ℕ) -> Bool {Zero} +testStack032 (Just d1) (Just d2) = testStack031 d1 d2 +testStack032 _ _ = False + +testStack03 : {m : Level } -> Stack ℕ (SingleLinkedStack ℕ) -> ((Maybe ℕ) -> (Maybe ℕ) -> Bool {m} ) -> Bool {m} +testStack03 s cs = pop2Stack s (\s d1 d2 -> cs d1 d2 ) + +testStack04 : Bool +testStack04 = testStack02 (\s -> testStack03 s testStack032) + +testStack05 : testStack04 ≡ True +testStack05 = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaStackTest.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,22 @@ +-- after push 1 and 2, pop2 get 1 and 2 + +testStack02 : {m : Level } @$\rightarrow$@ ( Stack @$\mathbb{N}$@ (SingleLinkedStack @$\mathbb{N}$@) @$\rightarrow$@ Bool {m} ) @$\rightarrow$@ Bool {m} +testStack02 cs = pushStack createSingleLinkedStack 1 (\s @$\rightarrow$@ pushStack s 2 cs) + + +testStack031 : (d1 d2 : @$\mathbb{N}$@ ) @$\rightarrow$@ Bool {Zero} +testStack031 2 1 = True +testStack031 _ _ = False + +testStack032 : (d1 d2 : Maybe @$\mathbb{N}$@) @$\rightarrow$@ Bool {Zero} +testStack032 (Just d1) (Just d2) = testStack031 d1 d2 +testStack032 _ _ = False + +testStack03 : {m : Level } @$\rightarrow$@ Stack @$\mathbb{N}$@ (SingleLinkedStack @$\mathbb{N}$@) @$\rightarrow$@ ((Maybe @$\mathbb{N}$@) @$\rightarrow$@ (Maybe @$\mathbb{N}$@) @$\rightarrow$@ Bool {m} ) @$\rightarrow$@ Bool {m} +testStack03 s cs = pop2Stack s (\s d1 d2 @$\rightarrow$@ cs d1 d2 ) + +testStack04 : Bool +testStack04 = testStack02 (\s @$\rightarrow$@ testStack03 s testStack032) + +testStack05 : testStack04 @$\equiv$@ True +testStack05 = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTree.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,22 @@ +record TreeMethods {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where + field + putImpl : treeImpl -> a -> (treeImpl -> t) -> t + getImpl : treeImpl -> (treeImpl -> Maybe a -> t) -> t +open TreeMethods + +record Tree {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where + field + tree : treeImpl + treeMethods : TreeMethods {n} {m} {a} {t} treeImpl + putTree : a -> (Tree treeImpl -> t) -> t + putTree d next = putImpl (treeMethods ) tree d (\t1 -> next (record {tree = t1 ; treeMethods = treeMethods} )) + getTree : (Tree treeImpl -> Maybe a -> t) -> t + getTree next = getImpl (treeMethods ) tree (\t1 d -> next (record {tree = t1 ; treeMethods = treeMethods} ) d ) +open Tree + +record RedBlackTree {n m : Level } {t : Set m} (a k : Set n) : Set (m Level.⊔ n) where + field + root : Maybe (Node a k) + nodeStack : SingleLinkedStack (Node a k) + compare : k -> k -> CompareResult {n} +open RedBlackTree
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTree.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,22 @@ +record TreeMethods {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + putImpl : treeImpl @$\rightarrow$@ a @$\rightarrow$@ (treeImpl @$\rightarrow$@ t) @$\rightarrow$@ t + getImpl : treeImpl @$\rightarrow$@ (treeImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t +open TreeMethods + +record Tree {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + tree : treeImpl + treeMethods : TreeMethods {n} {m} {a} {t} treeImpl + putTree : a @$\rightarrow$@ (Tree treeImpl @$\rightarrow$@ t) @$\rightarrow$@ t + putTree d next = putImpl (treeMethods ) tree d (\t1 @$\rightarrow$@ next (record {tree = t1 ; treeMethods = treeMethods} )) + getTree : (Tree treeImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + getTree next = getImpl (treeMethods ) tree (\t1 d @$\rightarrow$@ next (record {tree = t1 ; treeMethods = treeMethods} ) d ) +open Tree + +record RedBlackTree {n m : Level } {t : Set m} (a k : Set n) : Set (m Level.@$\sqcup$@ n) where + field + root : Maybe (Node a k) + nodeStack : SingleLinkedStack (Node a k) + compare : k @$\rightarrow$@ k @$\rightarrow$@ CompareResult {n} +open RedBlackTree
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeDebug.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +test31 = putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ ) 1 1 + $ \t -> putTree1 t 2 2 + $ \t -> putTree1 t 3 3 + $ \t -> putTree1 t 4 4 + $ \t -> getRedBlackTree t 4 + $ \t x -> x + +-- Just +-- (record +-- { key = 4 +-- ; value = 4 +-- ; right = Nothing +-- ; left = Nothing +-- ; color = Red +-- })
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeDebug.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +test31 = putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ ) 1 1 + $ \t @$\rightarrow$@ putTree1 t 2 2 + $ \t @$\rightarrow$@ putTree1 t 3 3 + $ \t @$\rightarrow$@ putTree1 t 4 4 + $ \t @$\rightarrow$@ getRedBlackTree t 4 + $ \t x @$\rightarrow$@ x + +-- Just +-- (record +-- { key = 4 +-- ; value = 4 +-- ; right = Nothing +-- ; left = Nothing +-- ; color = Red +-- })
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeDebugReturnNode4.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,16 @@ +test31 = putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ ) 1 1 +$ \t -> putTree1 t 2 2 +$ \t -> putTree1 t 3 3 +$ \t -> putTree1 t 4 4 +$ \t -> getRedBlackTree t 4 +$ \t x -> x + +-- C-c C-n test31 return + -- Just + -- (record + -- { key = 4 + -- ; value = 4 + -- ; right = Nothing + -- ; left = Nothing + -- ; color = Red + -- })
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeDebugReturnNode4.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,16 @@ +test31 = putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ ) 1 1 +$ \t @$\rightarrow$@ putTree1 t 2 2 +$ \t @$\rightarrow$@ putTree1 t 3 3 +$ \t @$\rightarrow$@ putTree1 t 4 4 +$ \t @$\rightarrow$@ getRedBlackTree t 4 +$ \t x @$\rightarrow$@ x + +-- C-c C-n test31 return + -- Just + -- (record + -- { key = 4 + -- ; value = 4 + -- ; right = Nothing + -- ; left = Nothing + -- ; color = Red + -- })
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeImpl.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,14 @@ +record TreeMethods {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where + field + putImpl : treeImpl -> a -> (treeImpl -> t) -> t + getImpl : treeImpl -> (treeImpl -> Maybe a -> t) -> t + +record Tree {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where + field + tree : treeImpl + treeMethods : TreeMethods {n} {m} {a} {t} treeImpl + putTree : a -> (Tree treeImpl -> t) -> t + putTree d next = putImpl (treeMethods ) tree d (\t1 -> next (record {tree = t1 ; treeMethods = treeMethods} )) + getTree : (Tree treeImpl -> Maybe a -> t) -> t + getTree next = getImpl (treeMethods ) tree (\t1 d -> next (record {tree = t1 ; treeMethods = treeMethods} ) d ) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeImpl.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,14 @@ +record TreeMethods {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + putImpl : treeImpl @$\rightarrow$@ a @$\rightarrow$@ (treeImpl @$\rightarrow$@ t) @$\rightarrow$@ t + getImpl : treeImpl @$\rightarrow$@ (treeImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + +record Tree {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + tree : treeImpl + treeMethods : TreeMethods {n} {m} {a} {t} treeImpl + putTree : a @$\rightarrow$@ (Tree treeImpl @$\rightarrow$@ t) @$\rightarrow$@ t + putTree d next = putImpl (treeMethods ) tree d (\t1 @$\rightarrow$@ next (record {tree = t1 ; treeMethods = treeMethods} )) + getTree : (Tree treeImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + getTree next = getImpl (treeMethods ) tree (\t1 d @$\rightarrow$@ next (record {tree = t1 ; treeMethods = treeMethods} ) d ) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeProof.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,34 @@ +redBlackInSomeState : { m : Level } (a : Set Level.zero) (n : Maybe (Node a ℕ)) {t : Set m} -> RedBlackTree {Level.zero} {m} {t} a ℕ +redBlackInSomeState {m} a n {t} = record { root = n ; nodeStack = emptySingleLinkedStack ; compare = compare2 } + +putTest1 :{ m : Level } (n : Maybe (Node ℕ ℕ)) + -> (k : ℕ) (x : ℕ) + -> putTree1 {_} {_} {ℕ} {ℕ} (redBlackInSomeState {_} ℕ n {Set Level.zero}) k x + (\ t -> getRedBlackTree t k (\ t x1 -> check2 x1 x ≡ True)) +putTest1 n k x with n +... | Just n1 = lemma2 ( record { top = Nothing } ) + where + lemma2 : (s : SingleLinkedStack (Node ℕ ℕ) ) -> putTree1 (record { root = Just n1 ; nodeStack = s ; compare = compare2 }) k x (λ t → + GetRedBlackTree.checkNode t k (λ t₁ x1 → check2 x1 x ≡ True) (root t)) + lemma2 s with compare2 k (key n1) + ... | EQ = lemma3 {!!} + where + lemma3 : compare2 k (key n1) ≡ EQ -> getRedBlackTree {_} {_} {ℕ} {ℕ} {Set Level.zero} ( record { root = Just ( record { + key = key n1 ; value = x ; right = right n1 ; left = left n1 ; color = Black + } ) ; nodeStack = s ; compare = λ x₁ y → compare2 x₁ y } ) k ( \ t x1 -> check2 x1 x ≡ True) + lemma3 eq with compare2 x x | putTest1Lemma2 x + ... | EQ | refl with compare2 k (key n1) | eq + ... | EQ | refl with compare2 x x | putTest1Lemma2 x + ... | EQ | refl = refl + ... | GT = {!!} + ... | LT = {!!} + +... | Nothing = lemma1 + where + lemma1 : getRedBlackTree {_} {_} {ℕ} {ℕ} {Set Level.zero} ( record { root = Just ( record { + key = k ; value = x ; right = Nothing ; left = Nothing ; color = Red + } ) ; nodeStack = record { top = Nothing } ; compare = λ x₁ y → compare2 x₁ y } ) k + ( \ t x1 -> check2 x1 x ≡ True) + lemma1 with compare2 k k | putTest1Lemma2 k + ... | EQ | refl with compare2 x x | putTest1Lemma2 x + ... | EQ | refl = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeProof.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,34 @@ +redBlackInSomeState : { m : Level } (a : Set Level.zero) (n : Maybe (Node a @$\mathbb{N}$@)) {t : Set m} @$\rightarrow$@ RedBlackTree {Level.zero} {m} {t} a @$\mathbb{N}$@ +redBlackInSomeState {m} a n {t} = record { root = n ; nodeStack = emptySingleLinkedStack ; compare = compare2 } + +putTest1 :{ m : Level } (n : Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@)) + @$\rightarrow$@ (k : @$\mathbb{N}$@) (x : @$\mathbb{N}$@) + @$\rightarrow$@ putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (redBlackInSomeState {_} @$\mathbb{N}$@ n {Set Level.zero}) k x + (\ t @$\rightarrow$@ getRedBlackTree t k (\ t x1 @$\rightarrow$@ check2 x1 x @$\equiv$@ True)) +putTest1 n k x with n +... | Just n1 = lemma2 ( record { top = Nothing } ) + where + lemma2 : (s : SingleLinkedStack (Node @$\mathbb{N}$@ @$\mathbb{N}$@) ) @$\rightarrow$@ putTree1 (record { root = Just n1 ; nodeStack = s ; compare = compare2 }) k x (@$\lambda$@ t @$\rightarrow$@ + GetRedBlackTree.checkNode t k (@$\lambda$@ t@$\_{1}$@ x1 @$\rightarrow$@ check2 x1 x @$\equiv$@ True) (root t)) + lemma2 s with compare2 k (key n1) + ... | EQ = lemma3 {!!} + where + lemma3 : compare2 k (key n1) @$\equiv$@ EQ @$\rightarrow$@ getRedBlackTree {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} {Set Level.zero} ( record { root = Just ( record { + key = key n1 ; value = x ; right = right n1 ; left = left n1 ; color = Black + } ) ; nodeStack = s ; compare = @$\lambda$@ x@$\_{1}$@ y @$\rightarrow$@ compare2 x@$\_{1}$@ y } ) k ( \ t x1 @$\rightarrow$@ check2 x1 x @$\equiv$@ True) + lemma3 eq with compare2 x x | putTest1Lemma2 x + ... | EQ | refl with compare2 k (key n1) | eq + ... | EQ | refl with compare2 x x | putTest1Lemma2 x + ... | EQ | refl = refl + ... | GT = {!!} + ... | LT = {!!} + +... | Nothing = lemma1 + where + lemma1 : getRedBlackTree {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} {Set Level.zero} ( record { root = Just ( record { + key = k ; value = x ; right = Nothing ; left = Nothing ; color = Red + } ) ; nodeStack = record { top = Nothing } ; compare = @$\lambda$@ x@$\_{1}$@ y @$\rightarrow$@ compare2 x@$\_{1}$@ y } ) k + ( \ t x1 @$\rightarrow$@ check2 x1 x @$\equiv$@ True) + lemma1 with compare2 k k | putTest1Lemma2 k + ... | EQ | refl with compare2 x x | putTest1Lemma2 x + ... | EQ | refl = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeTest.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +test31 = putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ ) 1 1 +$ \t -> putTree1 t 2 2 +$ \t -> putTree1 t 3 3 +$ \t -> putTree1 t 4 4 +$ \t -> getRedBlackTree t 4 +$ \t x -> x
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTreeTest.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +test31 = putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ ) 1 1 +$ \t @$\rightarrow$@ putTree1 t 2 2 +$ \t @$\rightarrow$@ putTree1 t 3 3 +$ \t @$\rightarrow$@ putTree1 t 4 4 +$ \t @$\rightarrow$@ getRedBlackTree t 4 +$ \t x @$\rightarrow$@ x
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTypeClass.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +record Eq (A : Set) : Set where + field + _==_ : A -> A -> Bool
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaTypeClass.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +record Eq (A : Set) : Set where + field + _==_ : A @$\rightarrow$@ A @$\rightarrow$@ Bool
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaWhere.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +f : Int -> Int -> Int +f a b c = (t a) + (t b) + (t c) + where + t x = x + x + x + +f' : Int -> Int -> Int +f' a b c = (a + a + a) + (b + b + b) + (c + c + c)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/AgdaWhere.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +f : Int @$\rightarrow$@ Int @$\rightarrow$@ Int +f a b c = (t a) + (t b) + (t c) + where + t x = x + x + x + +f' : Int @$\rightarrow$@ Int @$\rightarrow$@ Int +f' a b c = (a + a + a) + (b + b + b) + (c + c + c)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/CodeSegment.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +data CodeSegment {l1 l2 : Level} (I : Set l1) (O : Set l2) : Set (l ⊔ l1 ⊔ l2) where + cs : (I -> O) -> CodeSegment I O
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/CodeSegment.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +data CodeSegment {l1 l2 : Level} (I : Set l1) (O : Set l2) : Set (l @$\sqcup$@ l1 @$\sqcup$@ l2) where + cs : (I @$\rightarrow$@ O) @$\rightarrow$@ CodeSegment I O
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/CodeSegments.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +cs2 : CodeSegment ds1 ds1 +cs2 = cs id + +cs1 : CodeSegment ds1 ds1 +cs1 = cs (\d -> goto cs2 d) + +cs0 : CodeSegment ds0 ds1 +cs0 = cs (\d -> goto cs1 (record {c = (ds0.a d) + (ds0.b d)})) + +main : ds1 +main = goto cs0 (record {a = 100 ; b = 50}) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/CodeSegments.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +cs2 : CodeSegment ds1 ds1 +cs2 = cs id + +cs1 : CodeSegment ds1 ds1 +cs1 = cs (\d @$\rightarrow$@ goto cs2 d) + +cs0 : CodeSegment ds0 ds1 +cs0 = cs (\d @$\rightarrow$@ goto cs1 (record {c = (ds0.a d) + (ds0.b d)})) + +main : ds1 +main = goto cs0 (record {a = 100 ; b = 50}) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/DataSegment.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +record ds0 : Set where + field + a : Int + b : Int + +record ds1 : Set where + field + c : Int
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/DataSegment.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +record ds0 : Set where + field + a : Int + b : Int + +record ds1 : Set where + field + c : Int
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Equiv.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +data _≡_ {a} {A : Set a} (x : A) : A → Set a where refl : x ≡ x \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Equiv.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +data _@$\equiv$@_ {a} {A : Set a} (x : A) : A @$\rightarrow$@ Set a where refl : x @$\equiv$@ x \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Exec.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +exec : {l1 l2 : Level} {I : Set l1} {O : Set l2} + {{_ : DataSegment I}} {{_ : DataSegment O}} + -> CodeSegment I O -> Context -> Context +exec {l} {{i}} {{o}} (cs b) c = set o c (b (get i c)) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Exec.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +exec : {l1 l2 : Level} {I : Set l1} {O : Set l2} + {{_ : DataSegment I}} {{_ : DataSegment O}} + @$\rightarrow$@ CodeSegment I O @$\rightarrow$@ Context @$\rightarrow$@ Context +exec {l} {{i}} {{o}} (cs b) c = set o c (b (get i c)) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Goto.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +goto : {l1 l2 : Level} {I : Set l1} {O : Set l2} + -> CodeSegment I O -> I -> O +goto (cs b) i = b i +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Goto.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +goto : {l1 l2 : Level} {I : Set l1} {O : Set l2} + @$\rightarrow$@ CodeSegment I O @$\rightarrow$@ I @$\rightarrow$@ O +goto (cs b) i = b i +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Hoare.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,79 @@ +module Hoare + (PrimComm : Set) + (Cond : Set) + (Axiom : Cond -> PrimComm -> Cond -> Set) + (Tautology : Cond -> Cond -> Set) + (_and_ : Cond -> Cond -> Cond) + (neg : Cond -> Cond ) + where + +data Comm : Set where + Skip : Comm + Abort : Comm + PComm : PrimComm -> Comm + Seq : Comm -> Comm -> Comm + If : Cond -> Comm -> Comm -> Comm + While : Cond -> Comm -> Comm + +-- Hoare Triple +data HT : Set where + ht : Cond -> Comm -> Cond -> HT + +{- + prPre pr prPost + ------------- ------------------ ---------------- + bPre => bPre' {bPre'} c {bPost'} bPost' => bPost +Weakening : ---------------------------------------------------- + {bPre} c {bPost} + +Assign: ---------------------------- + {bPost[v<-e]} v:=e {bPost} + + pr1 pr2 + ----------------- ------------------ + {bPre} cm1 {bMid} {bMid} cm2 {bPost} +Seq: --------------------------------------- + {bPre} cm1 ; cm2 {bPost} + + pr1 pr2 + ----------------------- --------------------------- + {bPre /\ c} cm1 {bPost} {bPre /\ neg c} cm2 {bPost} +If: ------------------------------------------------------ + {bPre} If c then cm1 else cm2 fi {bPost} + + pr + ------------------- + {inv /\ c} cm {inv} +While: --------------------------------------- + {inv} while c do cm od {inv /\ neg c} +-} + + +data HTProof : Cond -> Comm -> Cond -> Set where + PrimRule : {bPre : Cond} -> {pcm : PrimComm} -> {bPost : Cond} -> + (pr : Axiom bPre pcm bPost) -> + HTProof bPre (PComm pcm) bPost + SkipRule : (b : Cond) -> HTProof b Skip b + AbortRule : (bPre : Cond) -> (bPost : Cond) -> + HTProof bPre Abort bPost + WeakeningRule : {bPre : Cond} -> {bPre' : Cond} -> {cm : Comm} -> + {bPost' : Cond} -> {bPost : Cond} -> + Tautology bPre bPre' -> + HTProof bPre' cm bPost' -> + Tautology bPost' bPost -> + HTProof bPre cm bPost + SeqRule : {bPre : Cond} -> {cm1 : Comm} -> {bMid : Cond} -> + {cm2 : Comm} -> {bPost : Cond} -> + HTProof bPre cm1 bMid -> + HTProof bMid cm2 bPost -> + HTProof bPre (Seq cm1 cm2) bPost + IfRule : {cmThen : Comm} -> {cmElse : Comm} -> + {bPre : Cond} -> {bPost : Cond} -> + {b : Cond} -> + HTProof (bPre and b) cmThen bPost -> + HTProof (bPre and neg b) cmElse bPost -> + HTProof bPre (If b cmThen cmElse) bPost + WhileRule : {cm : Comm} -> {bInv : Cond} -> {b : Cond} -> + HTProof (bInv and b) cm bInv -> + HTProof bInv (While b cm) (bInv and neg b) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Hoare.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,79 @@ +module Hoare + (PrimComm : Set) + (Cond : Set) + (Axiom : Cond @$\rightarrow$@ PrimComm @$\rightarrow$@ Cond @$\rightarrow$@ Set) + (Tautology : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Set) + (_and_ : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Cond) + (neg : Cond @$\rightarrow$@ Cond ) + where + +data Comm : Set where + Skip : Comm + Abort : Comm + PComm : PrimComm @$\rightarrow$@ Comm + Seq : Comm @$\rightarrow$@ Comm @$\rightarrow$@ Comm + If : Cond @$\rightarrow$@ Comm @$\rightarrow$@ Comm @$\rightarrow$@ Comm + While : Cond @$\rightarrow$@ Comm @$\rightarrow$@ Comm + +-- Hoare Triple +data HT : Set where + ht : Cond @$\rightarrow$@ Comm @$\rightarrow$@ Cond @$\rightarrow$@ HT + +{- + prPre pr prPost + ------------- ------------------ ---------------- + bPre => bPre' {bPre'} c {bPost'} bPost' => bPost +Weakening : ---------------------------------------------------- + {bPre} c {bPost} + +Assign: ---------------------------- + {bPost[v<-e]} v:=e {bPost} + + pr1 pr2 + ----------------- ------------------ + {bPre} cm1 {bMid} {bMid} cm2 {bPost} +Seq: --------------------------------------- + {bPre} cm1 ; cm2 {bPost} + + pr1 pr2 + ----------------------- --------------------------- + {bPre @$\wedge$@ c} cm1 {bPost} {bPre @$\wedge$@ neg c} cm2 {bPost} +If: ------------------------------------------------------ + {bPre} If c then cm1 else cm2 fi {bPost} + + pr + ------------------- + {inv @$\wedge$@ c} cm {inv} +While: --------------------------------------- + {inv} while c do cm od {inv @$\wedge$@ neg c} +-} + + +data HTProof : Cond @$\rightarrow$@ Comm @$\rightarrow$@ Cond @$\rightarrow$@ Set where + PrimRule : {bPre : Cond} @$\rightarrow$@ {pcm : PrimComm} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + (pr : Axiom bPre pcm bPost) @$\rightarrow$@ + HTProof bPre (PComm pcm) bPost + SkipRule : (b : Cond) @$\rightarrow$@ HTProof b Skip b + AbortRule : (bPre : Cond) @$\rightarrow$@ (bPost : Cond) @$\rightarrow$@ + HTProof bPre Abort bPost + WeakeningRule : {bPre : Cond} @$\rightarrow$@ {bPre' : Cond} @$\rightarrow$@ {cm : Comm} @$\rightarrow$@ + {bPost' : Cond} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + Tautology bPre bPre' @$\rightarrow$@ + HTProof bPre' cm bPost' @$\rightarrow$@ + Tautology bPost' bPost @$\rightarrow$@ + HTProof bPre cm bPost + SeqRule : {bPre : Cond} @$\rightarrow$@ {cm1 : Comm} @$\rightarrow$@ {bMid : Cond} @$\rightarrow$@ + {cm2 : Comm} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + HTProof bPre cm1 bMid @$\rightarrow$@ + HTProof bMid cm2 bPost @$\rightarrow$@ + HTProof bPre (Seq cm1 cm2) bPost + IfRule : {cmThen : Comm} @$\rightarrow$@ {cmElse : Comm} @$\rightarrow$@ + {bPre : Cond} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + {b : Cond} @$\rightarrow$@ + HTProof (bPre and b) cmThen bPost @$\rightarrow$@ + HTProof (bPre and neg b) cmElse bPost @$\rightarrow$@ + HTProof bPre (If b cmThen cmElse) bPost + WhileRule : {cm : Comm} @$\rightarrow$@ {bInv : Cond} @$\rightarrow$@ {b : Cond} @$\rightarrow$@ + HTProof (bInv and b) cm bInv @$\rightarrow$@ + HTProof bInv (While b cm) (bInv and neg b) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/HoareSoundness.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,197 @@ +{-# OPTIONS --universe-polymorphism #-} + +open import Level +open import Data.Nat.Base +open import Data.Product +open import Data.Bool.Base +open import Data.Empty +open import Data.Sum +open import Relation.Binary +open import Relation.Nullary +open import Relation.Binary.Core +open import Relation.Binary.PropositionalEquality +open import RelOp +open import utilities + +module HoareSoundness + (Cond : Set) + (PrimComm : Set) + (neg : Cond -> Cond) + (_/\_ : Cond -> Cond -> Cond) + (Tautology : Cond -> Cond -> Set) + (State : Set) + (SemCond : Cond -> State -> Set) + (tautValid : (b1 b2 : Cond) -> Tautology b1 b2 -> + (s : State) -> SemCond b1 s -> SemCond b2 s) + (respNeg : (b : Cond) -> (s : State) -> + Iff (SemCond (neg b) s) (¬ SemCond b s)) + (respAnd : (b1 b2 : Cond) -> (s : State) -> + Iff (SemCond (b1 /\ b2) s) + ((SemCond b1 s) × (SemCond b2 s))) + (PrimSemComm : ∀ {l} -> PrimComm -> Rel State l) + (Axiom : Cond -> PrimComm -> Cond -> Set) + (axiomValid : ∀ {l} -> (bPre : Cond) -> (pcm : PrimComm) -> (bPost : Cond) -> + (ax : Axiom bPre pcm bPost) -> (s1 s2 : State) -> + SemCond bPre s1 -> PrimSemComm {l} pcm s1 s2 -> SemCond bPost s2) where + +open import Hoare PrimComm Cond Axiom Tautology _/\_ neg + +open import RelOp +module RelOpState = RelOp State + +NotP : {S : Set} -> Pred S -> Pred S +NotP X s = ¬ X s + +_\/_ : Cond -> Cond -> Cond +b1 \/ b2 = neg (neg b1 /\ neg b2) + +when : {X Y Z : Set} -> (X -> Z) -> (Y -> Z) -> + X ⊎ Y -> Z +when f g (inj₁ x) = f x +when f g (inj₂ y) = g y + +-- semantics of commands +SemComm : Comm -> Rel State (Level.zero) +SemComm Skip = RelOpState.deltaGlob +SemComm Abort = RelOpState.emptyRel +SemComm (PComm pc) = PrimSemComm pc +SemComm (Seq c1 c2) = RelOpState.comp (SemComm c1) (SemComm c2) +SemComm (If b c1 c2) + = RelOpState.union + (RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm c1)) + (RelOpState.comp (RelOpState.delta (NotP (SemCond b))) + (SemComm c2)) +SemComm (While b c) + = RelOpState.unionInf + (λ (n : ℕ) -> + RelOpState.comp (RelOpState.repeat + n + (RelOpState.comp + (RelOpState.delta (SemCond b)) + (SemComm c))) + (RelOpState.delta (NotP (SemCond b)))) + +Satisfies : Cond -> Comm -> Cond -> Set +Satisfies bPre cm bPost + = (s1 : State) -> (s2 : State) -> + SemCond bPre s1 -> SemComm cm s1 s2 -> SemCond bPost s2 + +Soundness : {bPre : Cond} -> {cm : Comm} -> {bPost : Cond} -> + HTProof bPre cm bPost -> Satisfies bPre cm bPost +Soundness (PrimRule {bPre} {cm} {bPost} pr) s1 s2 q1 q2 + = axiomValid bPre cm bPost pr s1 s2 q1 q2 +Soundness {.bPost} {.Skip} {bPost} (SkipRule .bPost) s1 s2 q1 q2 + = substId1 State {Level.zero} {State} {s1} {s2} (proj₂ q2) (SemCond bPost) q1 +Soundness {bPre} {.Abort} {bPost} (AbortRule .bPre .bPost) s1 s2 q1 () +Soundness (WeakeningRule {bPre} {bPre'} {cm} {bPost'} {bPost} tautPre pr tautPost) + s1 s2 q1 q2 + = let hyp : Satisfies bPre' cm bPost' + hyp = Soundness pr + r1 : SemCond bPre' s1 + r1 = tautValid bPre bPre' tautPre s1 q1 + r2 : SemCond bPost' s2 + r2 = hyp s1 s2 r1 q2 + in tautValid bPost' bPost tautPost s2 r2 +Soundness (SeqRule {bPre} {cm1} {bMid} {cm2} {bPost} pr1 pr2) + s1 s2 q1 q2 + = let hyp1 : Satisfies bPre cm1 bMid + hyp1 = Soundness pr1 + hyp2 : Satisfies bMid cm2 bPost + hyp2 = Soundness pr2 + sMid : State + sMid = proj₁ q2 + r1 : SemComm cm1 s1 sMid × SemComm cm2 sMid s2 + r1 = proj₂ q2 + r2 : SemComm cm1 s1 sMid + r2 = proj₁ r1 + r3 : SemComm cm2 sMid s2 + r3 = proj₂ r1 + r4 : SemCond bMid sMid + r4 = hyp1 s1 sMid q1 r2 + in hyp2 sMid s2 r4 r3 +Soundness (IfRule {cmThen} {cmElse} {bPre} {bPost} {b} pThen pElse) + s1 s2 q1 q2 + = let hypThen : Satisfies (bPre /\ b) cmThen bPost + hypThen = Soundness pThen + hypElse : Satisfies (bPre /\ neg b) cmElse bPost + hypElse = Soundness pElse + rThen : RelOpState.comp + (RelOpState.delta (SemCond b)) + (SemComm cmThen) s1 s2 -> + SemCond bPost s2 + rThen = λ h -> + let t1 : SemCond b s1 × SemComm cmThen s1 s2 + t1 = (proj₂ (RelOpState.deltaRestPre + (SemCond b) + (SemComm cmThen) s1 s2)) h + t2 : SemCond (bPre /\ b) s1 + t2 = (proj₂ (respAnd bPre b s1)) + (q1 , proj₁ t1) + in hypThen s1 s2 t2 (proj₂ t1) + rElse : RelOpState.comp + (RelOpState.delta (NotP (SemCond b))) + (SemComm cmElse) s1 s2 -> + SemCond bPost s2 + rElse = λ h -> + let t10 : (NotP (SemCond b) s1) × + (SemComm cmElse s1 s2) + t10 = proj₂ (RelOpState.deltaRestPre + (NotP (SemCond b)) (SemComm cmElse) s1 s2) + h + t6 : SemCond (neg b) s1 + t6 = proj₂ (respNeg b s1) (proj₁ t10) + t7 : SemComm cmElse s1 s2 + t7 = proj₂ t10 + t8 : SemCond (bPre /\ neg b) s1 + t8 = proj₂ (respAnd bPre (neg b) s1) + (q1 , t6) + in hypElse s1 s2 t8 t7 + in when rThen rElse q2 +Soundness (WhileRule {cm'} {bInv} {b} pr) s1 s2 q1 q2 + = proj₂ (respAnd bInv (neg b) s2) t20 + where + hyp : Satisfies (bInv /\ b) cm' bInv + hyp = Soundness pr + n : ℕ + n = proj₁ q2 + Rel1 : ℕ -> Rel State (Level.zero) + Rel1 = λ m -> + RelOpState.repeat + m + (RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm cm')) + t1 : RelOpState.comp + (Rel1 n) + (RelOpState.delta (NotP (SemCond b))) s1 s2 + t1 = proj₂ q2 + t15 : (Rel1 n s1 s2) × (NotP (SemCond b) s2) + t15 = proj₂ (RelOpState.deltaRestPost + (NotP (SemCond b)) (Rel1 n) s1 s2) + t1 + t16 : Rel1 n s1 s2 + t16 = proj₁ t15 + t17 : NotP (SemCond b) s2 + t17 = proj₂ t15 + lem1 : (m : ℕ) -> (ss2 : State) -> Rel1 m s1 ss2 -> + SemCond bInv ss2 + lem1 ℕ.zero ss2 h + = substId1 State (proj₂ h) (SemCond bInv) q1 + lem1 (ℕ.suc n) ss2 h + = let hyp2 : (z : State) -> Rel1 n s1 z -> + SemCond bInv z + hyp2 = lem1 n + s20 : State + s20 = proj₁ h + t21 : Rel1 n s1 s20 + t21 = proj₁ (proj₂ h) + t22 : (SemCond b s20) × (SemComm cm' s20 ss2) + t22 = proj₂ (RelOpState.deltaRestPre + (SemCond b) (SemComm cm') s20 ss2) + (proj₂ (proj₂ h)) + t23 : SemCond (bInv /\ b) s20 + t23 = proj₂ (respAnd bInv b s20) + (hyp2 s20 t21 , proj₁ t22) + in hyp s20 ss2 t23 (proj₂ t22) + t20 : SemCond bInv s2 × SemCond (neg b) s2 + t20 = lem1 n s2 t16 , proj₂ (respNeg b s2) t17
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/HoareSoundness.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,197 @@ +{-@$\#$@ OPTIONS --universe-polymorphism @$\#$@-} + +open import Level +open import Data.Nat.Base +open import Data.Product +open import Data.Bool.Base +open import Data.Empty +open import Data.Sum +open import Relation.Binary +open import Relation.Nullary +open import Relation.Binary.Core +open import Relation.Binary.PropositionalEquality +open import RelOp +open import utilities + +module HoareSoundness + (Cond : Set) + (PrimComm : Set) + (neg : Cond @$\rightarrow$@ Cond) + (_@$\wedge$@_ : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Cond) + (Tautology : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Set) + (State : Set) + (SemCond : Cond @$\rightarrow$@ State @$\rightarrow$@ Set) + (tautValid : (b1 b2 : Cond) @$\rightarrow$@ Tautology b1 b2 @$\rightarrow$@ + (s : State) @$\rightarrow$@ SemCond b1 s @$\rightarrow$@ SemCond b2 s) + (respNeg : (b : Cond) @$\rightarrow$@ (s : State) @$\rightarrow$@ + Iff (SemCond (neg b) s) (@$\neg$@ SemCond b s)) + (respAnd : (b1 b2 : Cond) @$\rightarrow$@ (s : State) @$\rightarrow$@ + Iff (SemCond (b1 @$\wedge$@ b2) s) + ((SemCond b1 s) @$\times$@ (SemCond b2 s))) + (PrimSemComm : @$\forall$@ {l} @$\rightarrow$@ PrimComm @$\rightarrow$@ Rel State l) + (Axiom : Cond @$\rightarrow$@ PrimComm @$\rightarrow$@ Cond @$\rightarrow$@ Set) + (axiomValid : @$\forall$@ {l} @$\rightarrow$@ (bPre : Cond) @$\rightarrow$@ (pcm : PrimComm) @$\rightarrow$@ (bPost : Cond) @$\rightarrow$@ + (ax : Axiom bPre pcm bPost) @$\rightarrow$@ (s1 s2 : State) @$\rightarrow$@ + SemCond bPre s1 @$\rightarrow$@ PrimSemComm {l} pcm s1 s2 @$\rightarrow$@ SemCond bPost s2) where + +open import Hoare PrimComm Cond Axiom Tautology _@$\wedge$@_ neg + +open import RelOp +module RelOpState = RelOp State + +NotP : {S : Set} @$\rightarrow$@ Pred S @$\rightarrow$@ Pred S +NotP X s = @$\neg$@ X s + +_\/_ : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Cond +b1 \/ b2 = neg (neg b1 @$\wedge$@ neg b2) + +when : {X Y Z : Set} @$\rightarrow$@ (X @$\rightarrow$@ Z) @$\rightarrow$@ (Y @$\rightarrow$@ Z) @$\rightarrow$@ + X ⊎ Y @$\rightarrow$@ Z +when f g (inj@$\_{1}$@ x) = f x +when f g (inj@$\_{2}$@ y) = g y + +-- semantics of commands +SemComm : Comm @$\rightarrow$@ Rel State (Level.zero) +SemComm Skip = RelOpState.deltaGlob +SemComm Abort = RelOpState.emptyRel +SemComm (PComm pc) = PrimSemComm pc +SemComm (Seq c1 c2) = RelOpState.comp (SemComm c1) (SemComm c2) +SemComm (If b c1 c2) + = RelOpState.union + (RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm c1)) + (RelOpState.comp (RelOpState.delta (NotP (SemCond b))) + (SemComm c2)) +SemComm (While b c) + = RelOpState.unionInf + (@$\lambda$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ + RelOpState.comp (RelOpState.repeat + n + (RelOpState.comp + (RelOpState.delta (SemCond b)) + (SemComm c))) + (RelOpState.delta (NotP (SemCond b)))) + +Satisfies : Cond @$\rightarrow$@ Comm @$\rightarrow$@ Cond @$\rightarrow$@ Set +Satisfies bPre cm bPost + = (s1 : State) @$\rightarrow$@ (s2 : State) @$\rightarrow$@ + SemCond bPre s1 @$\rightarrow$@ SemComm cm s1 s2 @$\rightarrow$@ SemCond bPost s2 + +Soundness : {bPre : Cond} @$\rightarrow$@ {cm : Comm} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + HTProof bPre cm bPost @$\rightarrow$@ Satisfies bPre cm bPost +Soundness (PrimRule {bPre} {cm} {bPost} pr) s1 s2 q1 q2 + = axiomValid bPre cm bPost pr s1 s2 q1 q2 +Soundness {.bPost} {.Skip} {bPost} (SkipRule .bPost) s1 s2 q1 q2 + = substId1 State {Level.zero} {State} {s1} {s2} (proj@$\_{2}$@ q2) (SemCond bPost) q1 +Soundness {bPre} {.Abort} {bPost} (AbortRule .bPre .bPost) s1 s2 q1 () +Soundness (WeakeningRule {bPre} {bPre'} {cm} {bPost'} {bPost} tautPre pr tautPost) + s1 s2 q1 q2 + = let hyp : Satisfies bPre' cm bPost' + hyp = Soundness pr + r1 : SemCond bPre' s1 + r1 = tautValid bPre bPre' tautPre s1 q1 + r2 : SemCond bPost' s2 + r2 = hyp s1 s2 r1 q2 + in tautValid bPost' bPost tautPost s2 r2 +Soundness (SeqRule {bPre} {cm1} {bMid} {cm2} {bPost} pr1 pr2) + s1 s2 q1 q2 + = let hyp1 : Satisfies bPre cm1 bMid + hyp1 = Soundness pr1 + hyp2 : Satisfies bMid cm2 bPost + hyp2 = Soundness pr2 + sMid : State + sMid = proj@$\_{1}$@ q2 + r1 : SemComm cm1 s1 sMid @$\times$@ SemComm cm2 sMid s2 + r1 = proj@$\_{2}$@ q2 + r2 : SemComm cm1 s1 sMid + r2 = proj@$\_{1}$@ r1 + r3 : SemComm cm2 sMid s2 + r3 = proj@$\_{2}$@ r1 + r4 : SemCond bMid sMid + r4 = hyp1 s1 sMid q1 r2 + in hyp2 sMid s2 r4 r3 +Soundness (IfRule {cmThen} {cmElse} {bPre} {bPost} {b} pThen pElse) + s1 s2 q1 q2 + = let hypThen : Satisfies (bPre @$\wedge$@ b) cmThen bPost + hypThen = Soundness pThen + hypElse : Satisfies (bPre @$\wedge$@ neg b) cmElse bPost + hypElse = Soundness pElse + rThen : RelOpState.comp + (RelOpState.delta (SemCond b)) + (SemComm cmThen) s1 s2 @$\rightarrow$@ + SemCond bPost s2 + rThen = @$\lambda$@ h @$\rightarrow$@ + let t1 : SemCond b s1 @$\times$@ SemComm cmThen s1 s2 + t1 = (proj@$\_{2}$@ (RelOpState.deltaRestPre + (SemCond b) + (SemComm cmThen) s1 s2)) h + t2 : SemCond (bPre @$\wedge$@ b) s1 + t2 = (proj@$\_{2}$@ (respAnd bPre b s1)) + (q1 , proj@$\_{1}$@ t1) + in hypThen s1 s2 t2 (proj@$\_{2}$@ t1) + rElse : RelOpState.comp + (RelOpState.delta (NotP (SemCond b))) + (SemComm cmElse) s1 s2 @$\rightarrow$@ + SemCond bPost s2 + rElse = @$\lambda$@ h @$\rightarrow$@ + let t10 : (NotP (SemCond b) s1) @$\times$@ + (SemComm cmElse s1 s2) + t10 = proj@$\_{2}$@ (RelOpState.deltaRestPre + (NotP (SemCond b)) (SemComm cmElse) s1 s2) + h + t6 : SemCond (neg b) s1 + t6 = proj@$\_{2}$@ (respNeg b s1) (proj@$\_{1}$@ t10) + t7 : SemComm cmElse s1 s2 + t7 = proj@$\_{2}$@ t10 + t8 : SemCond (bPre @$\wedge$@ neg b) s1 + t8 = proj@$\_{2}$@ (respAnd bPre (neg b) s1) + (q1 , t6) + in hypElse s1 s2 t8 t7 + in when rThen rElse q2 +Soundness (WhileRule {cm'} {bInv} {b} pr) s1 s2 q1 q2 + = proj@$\_{2}$@ (respAnd bInv (neg b) s2) t20 + where + hyp : Satisfies (bInv @$\wedge$@ b) cm' bInv + hyp = Soundness pr + n : @$\mathbb{N}$@ + n = proj@$\_{1}$@ q2 + Rel1 : @$\mathbb{N}$@ @$\rightarrow$@ Rel State (Level.zero) + Rel1 = @$\lambda$@ m @$\rightarrow$@ + RelOpState.repeat + m + (RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm cm')) + t1 : RelOpState.comp + (Rel1 n) + (RelOpState.delta (NotP (SemCond b))) s1 s2 + t1 = proj@$\_{2}$@ q2 + t15 : (Rel1 n s1 s2) @$\times$@ (NotP (SemCond b) s2) + t15 = proj@$\_{2}$@ (RelOpState.deltaRestPost + (NotP (SemCond b)) (Rel1 n) s1 s2) + t1 + t16 : Rel1 n s1 s2 + t16 = proj@$\_{1}$@ t15 + t17 : NotP (SemCond b) s2 + t17 = proj@$\_{2}$@ t15 + lem1 : (m : @$\mathbb{N}$@) @$\rightarrow$@ (ss2 : State) @$\rightarrow$@ Rel1 m s1 ss2 @$\rightarrow$@ + SemCond bInv ss2 + lem1 @$\mathbb{N}$@.zero ss2 h + = substId1 State (proj@$\_{2}$@ h) (SemCond bInv) q1 + lem1 (@$\mathbb{N}$@.suc n) ss2 h + = let hyp2 : (z : State) @$\rightarrow$@ Rel1 n s1 z @$\rightarrow$@ + SemCond bInv z + hyp2 = lem1 n + s20 : State + s20 = proj@$\_{1}$@ h + t21 : Rel1 n s1 s20 + t21 = proj@$\_{1}$@ (proj@$\_{2}$@ h) + t22 : (SemCond b s20) @$\times$@ (SemComm cm' s20 ss2) + t22 = proj@$\_{2}$@ (RelOpState.deltaRestPre + (SemCond b) (SemComm cm') s20 ss2) + (proj@$\_{2}$@ (proj@$\_{2}$@ h)) + t23 : SemCond (bInv @$\wedge$@ b) s20 + t23 = proj@$\_{2}$@ (respAnd bInv b s20) + (hyp2 s20 t21 , proj@$\_{1}$@ t22) + in hyp s20 ss2 t23 (proj@$\_{2}$@ t22) + t20 : SemCond bInv s2 @$\times$@ SemCond (neg b) s2 + t20 = lem1 n s2 t16 , proj@$\_{2}$@ (respNeg b s2) t17
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Maybe.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +data Maybe {a} (A : Set a) : Set a where + just : (x : A) -> Maybe A + nothing : Maybe A
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Maybe.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +data Maybe {a} (A : Set a) : Set a where + just : (x : A) @$\rightarrow$@ Maybe A + nothing : Maybe A
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/MetaCodeSegment.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +data CodeSegment {l1 l2 : Level} (A : Set l1) (B : Set l2) : Set (l ⊔ l1 ⊔ l2) where + cs : {{_ : DataSegment A}} {{_ : DataSegment B}} + -> (A -> B) -> CodeSegment A B +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/MetaCodeSegment.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +data CodeSegment {l1 l2 : Level} (A : Set l1) (B : Set l2) : Set (l @$\sqcup$@ l1 @$\sqcup$@ l2) where + cs : {{_ : DataSegment A}} {{_ : DataSegment B}} + @$\rightarrow$@ (A @$\rightarrow$@ B) @$\rightarrow$@ CodeSegment A B +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/MetaDataSegment.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +module subtype {l : Level} (Context : Set l) where + +record DataSegment {ll : Level} (A : Set ll) : Set (l ⊔ ll) where + field + get : Context -> A + set : Context -> A -> Context +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/MetaDataSegment.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +module subtype {l : Level} (Context : Set l) where + +record DataSegment {ll : Level} (A : Set ll) : Set (l @$\sqcup$@ ll) where + field + get : Context @$\rightarrow$@ A + set : Context @$\rightarrow$@ A @$\rightarrow$@ Context +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/MetaMetaCodeSegment.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,29 @@ +-- meta level +liftContext : {X Y : Set} {{_ : N.DataSegment X}} {{_ : N.DataSegment Y}} -> N.CodeSegment X Y -> N.CodeSegment Context Context +liftContext {{x}} {{y}} (N.cs f) = N.cs (\c -> N.DataSegment.set y c (f (N.DataSegment.get x c))) + +liftMeta : {X Y : Set} {{_ : M.DataSegment X}} {{_ : M.DataSegment Y}} -> N.CodeSegment X Y -> M.CodeSegment X Y +liftMeta (N.cs f) = M.cs f + +gotoMeta : {I O : Set} {{_ : N.DataSegment I}} {{_ : N.DataSegment O}} -> M.CodeSegment Meta Meta -> N.CodeSegment I O -> Meta -> Meta +gotoMeta mCode code m = M.exec mCode (record m {next = (liftContext code)}) + +push : M.CodeSegment Meta Meta +push = M.cs (\m -> M.exec (liftMeta (Meta.next m)) (record m {c' = Context.c (Meta.context m)})) + +-- normal level + +cs2 : N.CodeSegment ds1 ds1 +cs2 = N.cs id + +cs1 : N.CodeSegment ds1 ds1 +cs1 = N.cs (\d -> N.goto cs2 d) + +cs0 : N.CodeSegment ds0 ds1 +cs0 = N.cs (\d -> N.goto cs1 (record {c = (ds0.a d) + (ds0.b d)})) + +-- meta level (with extended normal) +main : Meta +main = gotoMeta push cs0 (record {context = (record {a = 100 ; b = 50 ; c = 70}) ; c' = 0 ; next = (N.cs id)}) +-- record {context = record {a = 100 ; b = 50 ; c = 150} ; c' = 70 ; next = (N.cs id)} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/MetaMetaCodeSegment.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,29 @@ +-- meta level +liftContext : {X Y : Set} {{_ : N.DataSegment X}} {{_ : N.DataSegment Y}} @$\rightarrow$@ N.CodeSegment X Y @$\rightarrow$@ N.CodeSegment Context Context +liftContext {{x}} {{y}} (N.cs f) = N.cs (\c @$\rightarrow$@ N.DataSegment.set y c (f (N.DataSegment.get x c))) + +liftMeta : {X Y : Set} {{_ : M.DataSegment X}} {{_ : M.DataSegment Y}} @$\rightarrow$@ N.CodeSegment X Y @$\rightarrow$@ M.CodeSegment X Y +liftMeta (N.cs f) = M.cs f + +gotoMeta : {I O : Set} {{_ : N.DataSegment I}} {{_ : N.DataSegment O}} @$\rightarrow$@ M.CodeSegment Meta Meta @$\rightarrow$@ N.CodeSegment I O @$\rightarrow$@ Meta @$\rightarrow$@ Meta +gotoMeta mCode code m = M.exec mCode (record m {next = (liftContext code)}) + +push : M.CodeSegment Meta Meta +push = M.cs (\m @$\rightarrow$@ M.exec (liftMeta (Meta.next m)) (record m {c' = Context.c (Meta.context m)})) + +-- normal level + +cs2 : N.CodeSegment ds1 ds1 +cs2 = N.cs id + +cs1 : N.CodeSegment ds1 ds1 +cs1 = N.cs (\d @$\rightarrow$@ N.goto cs2 d) + +cs0 : N.CodeSegment ds0 ds1 +cs0 = N.cs (\d @$\rightarrow$@ N.goto cs1 (record {c = (ds0.a d) + (ds0.b d)})) + +-- meta level (with extended normal) +main : Meta +main = gotoMeta push cs0 (record {context = (record {a = 100 ; b = 50 ; c = 70}) ; c' = 0 ; next = (N.cs id)}) +-- record {context = record {a = 100 ; b = 50 ; c = 150} ; c' = 70 ; next = (N.cs id)} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/MetaMetaDataSegment.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +-- 上で各 DataSegement の定義を行なっているとする +open import subtype Context as N -- Meta Datasegment を定義 + +-- Meta DataSegment を持つ Meta Meta DataSegment を定義できる +record Meta : Set where + field + context : Context + c' : Int + next : N.CodeSegment Context Context + +open import subtype Meta as M +-- 以下よりメタメタレベルのプログラムを記述できる
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/MetaMetaDataSegment.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +-- 上で各 DataSegement の定義を行なっているとする +open import subtype Context as N -- Meta Datasegment を定義 + +-- Meta DataSegment を持つ Meta Meta DataSegment を定義できる +record Meta : Set where + field + context : Context + c' : Int + next : N.CodeSegment Context Context + +open import subtype Meta as M +-- 以下よりメタメタレベルのプログラムを記述できる
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Nat.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +data ℕ : Set where + zero : ℕ + suc : ℕ → ℕ + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Nat.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +data @$\mathbb{N}$@ : Set where + zero : @$\mathbb{N}$@ + suc : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/NatAdd.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +open import nat +module nat_add where + +_+_ : Nat -> Nat -> Nat +O + m = m +(S n) + m = S (n + m) \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/NatAdd.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +open import nat +module nat_add where + +_+_ : Nat @$\rightarrow$@ Nat @$\rightarrow$@ Nat +O + m = m +(S n) + m = S (n + m) \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/NatAddSym.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +open import Relation.Binary.PropositionalEquality +open import nat +open import nat_add +open ≡-Reasoning + +module nat_add_sym where + +addSym : (n m : Nat) -> n + m ≡ m + n +addSym O O = refl +addSym O (S m) = cong S (addSym O m) +addSym (S n) O = cong S (addSym n O) +addSym (S n) (S m) = {!!} -- 後述
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/NatAddSym.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +open import Relation.Binary.PropositionalEquality +open import nat +open import nat_add +open @$\equiv$@-Reasoning + +module nat_add_sym where + +addSym : (n m : Nat) @$\rightarrow$@ n + m @$\equiv$@ m + n +addSym O O = refl +addSym O (S m) = cong S (addSym O m) +addSym (S n) O = cong S (addSym n O) +addSym (S n) (S m) = {!!} -- 後述
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/PushPopType.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +pushOnce : Meta -> Meta +pushOnce m = M.exec pushSingleLinkedStackCS m + +popOnce : Meta -> Meta +popOnce m = M.exec popSingleLinkedStackCS m + +push-pop-type : Meta -> Set₁ +push-pop-type meta = + M.exec (M.csComp (M.cs popOnce) (M.cs pushOnce)) meta ≡ meta
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/PushPopType.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +pushOnce : Meta @$\rightarrow$@ Meta +pushOnce m = M.exec pushSingleLinkedStackCS m + +popOnce : Meta @$\rightarrow$@ Meta +popOnce m = M.exec popSingleLinkedStackCS m + +push-pop-type : Meta @$\rightarrow$@ Set@$\_{1}$@ +push-pop-type meta = + M.exec (M.csComp (M.cs popOnce) (M.cs pushOnce)) meta @$\equiv$@ meta
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Reasoning.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,21 @@ +open import Relation.Binary.PropositionalEquality +open import nat +open import nat_add +open ≡-Reasoning + +module nat_add_sym_reasoning where + +addToRight : (n m : Nat) -> S (n + m) ≡ n + (S m) +addToRight O m = refl +addToRight (S n) m = cong S (addToRight n m) + +addSym : (n m : Nat) -> n + m ≡ m + n +addSym O O = refl +addSym O (S m) = cong S (addSym O m) +addSym (S n) O = cong S (addSym n O) +addSym (S n) (S m) = begin + (S n) + (S m) ≡⟨ refl ⟩ + S (n + S m) ≡⟨ cong S (addSym n (S m)) ⟩ + S ((S m) + n) ≡⟨ addToRight (S m) n ⟩ + S (m + S n) ≡⟨ refl ⟩ + (S m) + (S n) ∎
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Reasoning.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,21 @@ +open import Relation.Binary.PropositionalEquality +open import nat +open import nat_add +open @$\equiv$@-Reasoning + +module nat_add_sym_reasoning where + +addToRight : (n m : Nat) @$\rightarrow$@ S (n + m) @$\equiv$@ n + (S m) +addToRight O m = refl +addToRight (S n) m = cong S (addToRight n m) + +addSym : (n m : Nat) @$\rightarrow$@ n + m @$\equiv$@ m + n +addSym O O = refl +addSym O (S m) = cong S (addSym O m) +addSym (S n) O = cong S (addSym n O) +addSym (S n) (S m) = begin + (S n) + (S m) @$\equiv$@@$\langle$@ refl @$\rangle$@ + S (n + S m) @$\equiv$@@$\langle$@ cong S (addSym n (S m)) @$\rangle$@ + S ((S m) + n) @$\equiv$@@$\langle$@ addToRight (S m) n @$\rangle$@ + S (m + S n) @$\equiv$@@$\langle$@ refl @$\rangle$@ + (S m) + (S n) @$\blacksquare$@
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/RedBlackTree.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,231 @@ +module RedBlackTree where + +open import stack +open import Level hiding (zero) +record TreeMethods {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where + field + putImpl : treeImpl -> a -> (treeImpl -> t) -> t + getImpl : treeImpl -> (treeImpl -> Maybe a -> t) -> t +open TreeMethods + +record Tree {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where + field + tree : treeImpl + treeMethods : TreeMethods {n} {m} {a} {t} treeImpl + putTree : a -> (Tree treeImpl -> t) -> t + putTree d next = putImpl (treeMethods ) tree d (\t1 -> next (record {tree = t1 ; treeMethods = treeMethods} )) + getTree : (Tree treeImpl -> Maybe a -> t) -> t + getTree next = getImpl (treeMethods ) tree (\t1 d -> next (record {tree = t1 ; treeMethods = treeMethods} ) d ) + +open Tree + +data Color {n : Level } : Set n where + Red : Color + Black : Color + +data CompareResult {n : Level } : Set n where + LT : CompareResult + GT : CompareResult + EQ : CompareResult + +record Node {n : Level } (a k : Set n) : Set n where + inductive + field + key : k + value : a + right : Maybe (Node a k) + left : Maybe (Node a k) + color : Color {n} +open Node + +record RedBlackTree {n m : Level } {t : Set m} (a k : Set n) : Set (m Level.⊔ n) where + field + root : Maybe (Node a k) + nodeStack : SingleLinkedStack (Node a k) + compare : k -> k -> CompareResult {n} + +open RedBlackTree + +open SingleLinkedStack + +-- +-- put new node at parent node, and rebuild tree to the top +-- +{-# TERMINATING #-} -- https://agda.readthedocs.io/en/v2.5.3/language/termination-checking.html +replaceNode : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Node a k -> (RedBlackTree {n} {m} {t} a k -> t) -> t +replaceNode {n} {m} {t} {a} {k} tree s n0 next = popSingleLinkedStack s ( + \s parent -> replaceNode1 s parent) + where + replaceNode1 : SingleLinkedStack (Node a k) -> Maybe ( Node a k ) -> t + replaceNode1 s Nothing = next ( record tree { root = Just (record n0 { color = Black}) } ) + replaceNode1 s (Just n1) with compare tree (key n1) (key n0) + ... | EQ = replaceNode tree s ( record n1 { value = value n0 ; left = left n0 ; right = right n0 } ) next + ... | GT = replaceNode tree s ( record n1 { left = Just n0 } ) next + ... | LT = replaceNode tree s ( record n1 { right = Just n0 } ) next + + +rotateRight : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> + (RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> t) -> t +rotateRight {n} {m} {t} {a} {k} tree s n0 parent rotateNext = getSingleLinkedStack s (\ s n0 -> rotateRight1 tree s n0 parent rotateNext) + where + rotateRight1 : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> + (RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> t) -> t + rotateRight1 {n} {m} {t} {a} {k} tree s n0 parent rotateNext with n0 + ... | Nothing = rotateNext tree s Nothing n0 + ... | Just n1 with parent + ... | Nothing = rotateNext tree s (Just n1 ) n0 + ... | Just parent1 with left parent1 + ... | Nothing = rotateNext tree s (Just n1) Nothing + ... | Just leftParent with compare tree (key n1) (key leftParent) + ... | EQ = rotateNext tree s (Just n1) parent + ... | _ = rotateNext tree s (Just n1) parent + + +rotateLeft : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> + (RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> t) -> t +rotateLeft {n} {m} {t} {a} {k} tree s n0 parent rotateNext = getSingleLinkedStack s (\ s n0 -> rotateLeft1 tree s n0 parent rotateNext) + where + rotateLeft1 : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> + (RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> t) -> t + rotateLeft1 {n} {m} {t} {a} {k} tree s n0 parent rotateNext with n0 + ... | Nothing = rotateNext tree s Nothing n0 + ... | Just n1 with parent + ... | Nothing = rotateNext tree s (Just n1) Nothing + ... | Just parent1 with right parent1 + ... | Nothing = rotateNext tree s (Just n1) Nothing + ... | Just rightParent with compare tree (key n1) (key rightParent) + ... | EQ = rotateNext tree s (Just n1) parent + ... | _ = rotateNext tree s (Just n1) parent + +{-# TERMINATING #-} +insertCase5 : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Node a k -> Node a k -> (RedBlackTree {n} {m} {t} a k -> t) -> t +insertCase5 {n} {m} {t} {a} {k} tree s n0 parent grandParent next = pop2SingleLinkedStack s (\ s parent grandParent -> insertCase51 tree s n0 parent grandParent next) + where + insertCase51 : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> (RedBlackTree {n} {m} {t} a k -> t) -> t + insertCase51 {n} {m} {t} {a} {k} tree s n0 parent grandParent next with n0 + ... | Nothing = next tree + ... | Just n1 with parent | grandParent + ... | Nothing | _ = next tree + ... | _ | Nothing = next tree + ... | Just parent1 | Just grandParent1 with left parent1 | left grandParent1 + ... | Nothing | _ = next tree + ... | _ | Nothing = next tree + ... | Just leftParent1 | Just leftGrandParent1 + with compare tree (key n1) (key leftParent1) | compare tree (key leftParent1) (key leftGrandParent1) + ... | EQ | EQ = rotateRight tree s n0 parent + (\ tree s n0 parent -> insertCase5 tree s n0 parent1 grandParent1 next) + ... | _ | _ = rotateLeft tree s n0 parent + (\ tree s n0 parent -> insertCase5 tree s n0 parent1 grandParent1 next) + +insertCase4 : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Node a k -> Node a k -> Node a k -> (RedBlackTree {n} {m} {t} a k -> t) -> t +insertCase4 {n} {m} {t} {a} {k} tree s n0 parent grandParent next + with (right parent) | (left grandParent) +... | Nothing | _ = insertCase5 tree s (Just n0) parent grandParent next +... | _ | Nothing = insertCase5 tree s (Just n0) parent grandParent next +... | Just rightParent | Just leftGrandParent with compare tree (key n0) (key rightParent) | compare tree (key parent) (key leftGrandParent) +... | EQ | EQ = popSingleLinkedStack s (\ s n1 -> rotateLeft tree s (left n0) (Just grandParent) + (\ tree s n0 parent -> insertCase5 tree s n0 rightParent grandParent next)) +... | _ | _ = insertCase41 tree s n0 parent grandParent next + where + insertCase41 : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Node a k -> Node a k -> Node a k -> (RedBlackTree {n} {m} {t} a k -> t) -> t + insertCase41 {n} {m} {t} {a} {k} tree s n0 parent grandParent next + with (left parent) | (right grandParent) + ... | Nothing | _ = insertCase5 tree s (Just n0) parent grandParent next + ... | _ | Nothing = insertCase5 tree s (Just n0) parent grandParent next + ... | Just leftParent | Just rightGrandParent with compare tree (key n0) (key leftParent) | compare tree (key parent) (key rightGrandParent) + ... | EQ | EQ = popSingleLinkedStack s (\ s n1 -> rotateRight tree s (right n0) (Just grandParent) + (\ tree s n0 parent -> insertCase5 tree s n0 leftParent grandParent next)) + ... | _ | _ = insertCase5 tree s (Just n0) parent grandParent next + +colorNode : {n : Level } {a k : Set n} -> Node a k -> Color -> Node a k +colorNode old c = record old { color = c } + +{-# TERMINATING #-} +insertNode : {n m : Level } {t : Set m } {a k : Set n} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Node a k -> (RedBlackTree {n} {m} {t} a k -> t) -> t +insertNode {n} {m} {t} {a} {k} tree s n0 next = get2SingleLinkedStack s (insertCase1 n0) + where + insertCase1 : Node a k -> SingleLinkedStack (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> t -- placed here to allow mutual recursion + -- http://agda.readthedocs.io/en/v2.5.2/language/mutual-recursion.html + insertCase3 : SingleLinkedStack (Node a k) -> Node a k -> Node a k -> Node a k -> t + insertCase3 s n0 parent grandParent with left grandParent | right grandParent + ... | Nothing | Nothing = insertCase4 tree s n0 parent grandParent next + ... | Nothing | Just uncle = insertCase4 tree s n0 parent grandParent next + ... | Just uncle | _ with compare tree ( key uncle ) ( key parent ) + ... | EQ = insertCase4 tree s n0 parent grandParent next + ... | _ with color uncle + ... | Red = pop2SingleLinkedStack s ( \s p0 p1 -> insertCase1 ( + record grandParent { color = Red ; left = Just ( record parent { color = Black } ) ; right = Just ( record uncle { color = Black } ) }) s p0 p1 ) + ... | Black = insertCase4 tree s n0 parent grandParent next + insertCase2 : SingleLinkedStack (Node a k) -> Node a k -> Node a k -> Node a k -> t + insertCase2 s n0 parent grandParent with color parent + ... | Black = replaceNode tree s n0 next + ... | Red = insertCase3 s n0 parent grandParent + insertCase1 n0 s Nothing Nothing = next tree + insertCase1 n0 s Nothing (Just grandParent) = next tree + insertCase1 n0 s (Just parent) Nothing = replaceNode tree s (colorNode n0 Black) next + insertCase1 n0 s (Just parent) (Just grandParent) = insertCase2 s n0 parent grandParent + +---- +-- find node potition to insert or to delete, the path will be in the stack +-- +findNode : {n m : Level } {a k : Set n} {t : Set m} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> (Node a k) -> (Node a k) -> (RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Node a k -> t) -> t +findNode {n} {m} {a} {k} {t} tree s n0 n1 next = pushSingleLinkedStack s n1 (\ s -> findNode1 s n1) + where + findNode2 : SingleLinkedStack (Node a k) -> (Maybe (Node a k)) -> t + findNode2 s Nothing = next tree s n0 + findNode2 s (Just n) = findNode tree s n0 n next + findNode1 : SingleLinkedStack (Node a k) -> (Node a k) -> t + findNode1 s n1 with (compare tree (key n0) (key n1)) + ... | EQ = popSingleLinkedStack s ( \s _ -> next tree s (record n1 { key = key n1 ; value = value n0 } ) ) + ... | GT = findNode2 s (right n1) + ... | LT = findNode2 s (left n1) + + +leafNode : {n : Level } {a k : Set n} -> k -> a -> Node a k +leafNode k1 value = record { + key = k1 ; + value = value ; + right = Nothing ; + left = Nothing ; + color = Red + } + +putRedBlackTree : {n m : Level } {a k : Set n} {t : Set m} -> RedBlackTree {n} {m} {t} a k -> k -> a -> (RedBlackTree {n} {m} {t} a k -> t) -> t +putRedBlackTree {n} {m} {a} {k} {t} tree k1 value next with (root tree) +... | Nothing = next (record tree {root = Just (leafNode k1 value) }) +... | Just n2 = clearSingleLinkedStack (nodeStack tree) (\ s -> findNode tree s (leafNode k1 value) n2 (\ tree1 s n1 -> insertNode tree1 s n1 next)) + +getRedBlackTree : {n m : Level } {a k : Set n} {t : Set m} -> RedBlackTree {n} {m} {t} a k -> k -> (RedBlackTree {n} {m} {t} a k -> (Maybe (Node a k)) -> t) -> t +getRedBlackTree {_} {_} {a} {k} {t} tree k1 cs = checkNode (root tree) + module GetRedBlackTree where -- http://agda.readthedocs.io/en/v2.5.2/language/let-and-where.html + search : Node a k -> t + checkNode : Maybe (Node a k) -> t + checkNode Nothing = cs tree Nothing + checkNode (Just n) = search n + search n with compare tree k1 (key n) + search n | LT = checkNode (left n) + search n | GT = checkNode (right n) + search n | EQ = cs tree (Just n) + +open import Data.Nat hiding (compare) + +compareℕ : ℕ → ℕ → CompareResult {Level.zero} +compareℕ x y with Data.Nat.compare x y +... | less _ _ = LT +... | equal _ = EQ +... | greater _ _ = GT + +compare2 : (x y : ℕ ) -> CompareResult {Level.zero} +compare2 zero zero = EQ +compare2 (suc _) zero = GT +compare2 zero (suc _) = LT +compare2 (suc x) (suc y) = compare2 x y + + +createEmptyRedBlackTreeℕ : { m : Level } (a : Set Level.zero) {t : Set m} -> RedBlackTree {Level.zero} {m} {t} a ℕ +createEmptyRedBlackTreeℕ {m} a {t} = record { + root = Nothing + ; nodeStack = emptySingleLinkedStack + ; compare = compare2 + } +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/RedBlackTree.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,231 @@ +module RedBlackTree where + +open import stack +open import Level hiding (zero) +record TreeMethods {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + putImpl : treeImpl @$\rightarrow$@ a @$\rightarrow$@ (treeImpl @$\rightarrow$@ t) @$\rightarrow$@ t + getImpl : treeImpl @$\rightarrow$@ (treeImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t +open TreeMethods + +record Tree {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + tree : treeImpl + treeMethods : TreeMethods {n} {m} {a} {t} treeImpl + putTree : a @$\rightarrow$@ (Tree treeImpl @$\rightarrow$@ t) @$\rightarrow$@ t + putTree d next = putImpl (treeMethods ) tree d (\t1 @$\rightarrow$@ next (record {tree = t1 ; treeMethods = treeMethods} )) + getTree : (Tree treeImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + getTree next = getImpl (treeMethods ) tree (\t1 d @$\rightarrow$@ next (record {tree = t1 ; treeMethods = treeMethods} ) d ) + +open Tree + +data Color {n : Level } : Set n where + Red : Color + Black : Color + +data CompareResult {n : Level } : Set n where + LT : CompareResult + GT : CompareResult + EQ : CompareResult + +record Node {n : Level } (a k : Set n) : Set n where + inductive + field + key : k + value : a + right : Maybe (Node a k) + left : Maybe (Node a k) + color : Color {n} +open Node + +record RedBlackTree {n m : Level } {t : Set m} (a k : Set n) : Set (m Level.@$\sqcup$@ n) where + field + root : Maybe (Node a k) + nodeStack : SingleLinkedStack (Node a k) + compare : k @$\rightarrow$@ k @$\rightarrow$@ CompareResult {n} + +open RedBlackTree + +open SingleLinkedStack + +-- +-- put new node at parent node, and rebuild tree to the top +-- +{-@$\#$@ TERMINATING @$\#$@-} -- https://agda.readthedocs.io/en/v2.5.3/language/termination-checking.html +replaceNode : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ t) @$\rightarrow$@ t +replaceNode {n} {m} {t} {a} {k} tree s n0 next = popSingleLinkedStack s ( + \s parent @$\rightarrow$@ replaceNode1 s parent) + where + replaceNode1 : SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe ( Node a k ) @$\rightarrow$@ t + replaceNode1 s Nothing = next ( record tree { root = Just (record n0 { color = Black}) } ) + replaceNode1 s (Just n1) with compare tree (key n1) (key n0) + ... | EQ = replaceNode tree s ( record n1 { value = value n0 ; left = left n0 ; right = right n0 } ) next + ... | GT = replaceNode tree s ( record n1 { left = Just n0 } ) next + ... | LT = replaceNode tree s ( record n1 { right = Just n0 } ) next + + +rotateRight : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ + (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ t) @$\rightarrow$@ t +rotateRight {n} {m} {t} {a} {k} tree s n0 parent rotateNext = getSingleLinkedStack s (\ s n0 @$\rightarrow$@ rotateRight1 tree s n0 parent rotateNext) + where + rotateRight1 : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ + (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ t) @$\rightarrow$@ t + rotateRight1 {n} {m} {t} {a} {k} tree s n0 parent rotateNext with n0 + ... | Nothing = rotateNext tree s Nothing n0 + ... | Just n1 with parent + ... | Nothing = rotateNext tree s (Just n1 ) n0 + ... | Just parent1 with left parent1 + ... | Nothing = rotateNext tree s (Just n1) Nothing + ... | Just leftParent with compare tree (key n1) (key leftParent) + ... | EQ = rotateNext tree s (Just n1) parent + ... | _ = rotateNext tree s (Just n1) parent + + +rotateLeft : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ + (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ t) @$\rightarrow$@ t +rotateLeft {n} {m} {t} {a} {k} tree s n0 parent rotateNext = getSingleLinkedStack s (\ s n0 @$\rightarrow$@ rotateLeft1 tree s n0 parent rotateNext) + where + rotateLeft1 : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ + (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ t) @$\rightarrow$@ t + rotateLeft1 {n} {m} {t} {a} {k} tree s n0 parent rotateNext with n0 + ... | Nothing = rotateNext tree s Nothing n0 + ... | Just n1 with parent + ... | Nothing = rotateNext tree s (Just n1) Nothing + ... | Just parent1 with right parent1 + ... | Nothing = rotateNext tree s (Just n1) Nothing + ... | Just rightParent with compare tree (key n1) (key rightParent) + ... | EQ = rotateNext tree s (Just n1) parent + ... | _ = rotateNext tree s (Just n1) parent + +{-@$\#$@ TERMINATING @$\#$@-} +insertCase5 : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ t) @$\rightarrow$@ t +insertCase5 {n} {m} {t} {a} {k} tree s n0 parent grandParent next = pop2SingleLinkedStack s (\ s parent grandParent @$\rightarrow$@ insertCase51 tree s n0 parent grandParent next) + where + insertCase51 : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ t) @$\rightarrow$@ t + insertCase51 {n} {m} {t} {a} {k} tree s n0 parent grandParent next with n0 + ... | Nothing = next tree + ... | Just n1 with parent | grandParent + ... | Nothing | _ = next tree + ... | _ | Nothing = next tree + ... | Just parent1 | Just grandParent1 with left parent1 | left grandParent1 + ... | Nothing | _ = next tree + ... | _ | Nothing = next tree + ... | Just leftParent1 | Just leftGrandParent1 + with compare tree (key n1) (key leftParent1) | compare tree (key leftParent1) (key leftGrandParent1) + ... | EQ | EQ = rotateRight tree s n0 parent + (\ tree s n0 parent @$\rightarrow$@ insertCase5 tree s n0 parent1 grandParent1 next) + ... | _ | _ = rotateLeft tree s n0 parent + (\ tree s n0 parent @$\rightarrow$@ insertCase5 tree s n0 parent1 grandParent1 next) + +insertCase4 : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ t) @$\rightarrow$@ t +insertCase4 {n} {m} {t} {a} {k} tree s n0 parent grandParent next + with (right parent) | (left grandParent) +... | Nothing | _ = insertCase5 tree s (Just n0) parent grandParent next +... | _ | Nothing = insertCase5 tree s (Just n0) parent grandParent next +... | Just rightParent | Just leftGrandParent with compare tree (key n0) (key rightParent) | compare tree (key parent) (key leftGrandParent) +... | EQ | EQ = popSingleLinkedStack s (\ s n1 @$\rightarrow$@ rotateLeft tree s (left n0) (Just grandParent) + (\ tree s n0 parent @$\rightarrow$@ insertCase5 tree s n0 rightParent grandParent next)) +... | _ | _ = insertCase41 tree s n0 parent grandParent next + where + insertCase41 : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ t) @$\rightarrow$@ t + insertCase41 {n} {m} {t} {a} {k} tree s n0 parent grandParent next + with (left parent) | (right grandParent) + ... | Nothing | _ = insertCase5 tree s (Just n0) parent grandParent next + ... | _ | Nothing = insertCase5 tree s (Just n0) parent grandParent next + ... | Just leftParent | Just rightGrandParent with compare tree (key n0) (key leftParent) | compare tree (key parent) (key rightGrandParent) + ... | EQ | EQ = popSingleLinkedStack s (\ s n1 @$\rightarrow$@ rotateRight tree s (right n0) (Just grandParent) + (\ tree s n0 parent @$\rightarrow$@ insertCase5 tree s n0 leftParent grandParent next)) + ... | _ | _ = insertCase5 tree s (Just n0) parent grandParent next + +colorNode : {n : Level } {a k : Set n} @$\rightarrow$@ Node a k @$\rightarrow$@ Color @$\rightarrow$@ Node a k +colorNode old c = record old { color = c } + +{-@$\#$@ TERMINATING @$\#$@-} +insertNode : {n m : Level } {t : Set m } {a k : Set n} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ t) @$\rightarrow$@ t +insertNode {n} {m} {t} {a} {k} tree s n0 next = get2SingleLinkedStack s (insertCase1 n0) + where + insertCase1 : Node a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ Maybe (Node a k) @$\rightarrow$@ t -- placed here to allow mutual recursion + -- http://agda.readthedocs.io/en/v2.5.2/language/mutual-recursion.html + insertCase3 : SingleLinkedStack (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ t + insertCase3 s n0 parent grandParent with left grandParent | right grandParent + ... | Nothing | Nothing = insertCase4 tree s n0 parent grandParent next + ... | Nothing | Just uncle = insertCase4 tree s n0 parent grandParent next + ... | Just uncle | _ with compare tree ( key uncle ) ( key parent ) + ... | EQ = insertCase4 tree s n0 parent grandParent next + ... | _ with color uncle + ... | Red = pop2SingleLinkedStack s ( \s p0 p1 @$\rightarrow$@ insertCase1 ( + record grandParent { color = Red ; left = Just ( record parent { color = Black } ) ; right = Just ( record uncle { color = Black } ) }) s p0 p1 ) + ... | Black = insertCase4 tree s n0 parent grandParent next + insertCase2 : SingleLinkedStack (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ Node a k @$\rightarrow$@ t + insertCase2 s n0 parent grandParent with color parent + ... | Black = replaceNode tree s n0 next + ... | Red = insertCase3 s n0 parent grandParent + insertCase1 n0 s Nothing Nothing = next tree + insertCase1 n0 s Nothing (Just grandParent) = next tree + insertCase1 n0 s (Just parent) Nothing = replaceNode tree s (colorNode n0 Black) next + insertCase1 n0 s (Just parent) (Just grandParent) = insertCase2 s n0 parent grandParent + +---- +-- find node potition to insert or to delete, the path will be in the stack +-- +findNode : {n m : Level } {a k : Set n} {t : Set m} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ (Node a k) @$\rightarrow$@ (Node a k) @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ t) @$\rightarrow$@ t +findNode {n} {m} {a} {k} {t} tree s n0 n1 next = pushSingleLinkedStack s n1 (\ s @$\rightarrow$@ findNode1 s n1) + where + findNode2 : SingleLinkedStack (Node a k) @$\rightarrow$@ (Maybe (Node a k)) @$\rightarrow$@ t + findNode2 s Nothing = next tree s n0 + findNode2 s (Just n) = findNode tree s n0 n next + findNode1 : SingleLinkedStack (Node a k) @$\rightarrow$@ (Node a k) @$\rightarrow$@ t + findNode1 s n1 with (compare tree (key n0) (key n1)) + ... | EQ = popSingleLinkedStack s ( \s _ @$\rightarrow$@ next tree s (record n1 { key = key n1 ; value = value n0 } ) ) + ... | GT = findNode2 s (right n1) + ... | LT = findNode2 s (left n1) + + +leafNode : {n : Level } {a k : Set n} @$\rightarrow$@ k @$\rightarrow$@ a @$\rightarrow$@ Node a k +leafNode k1 value = record { + key = k1 ; + value = value ; + right = Nothing ; + left = Nothing ; + color = Red + } + +putRedBlackTree : {n m : Level } {a k : Set n} {t : Set m} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ k @$\rightarrow$@ a @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ t) @$\rightarrow$@ t +putRedBlackTree {n} {m} {a} {k} {t} tree k1 value next with (root tree) +... | Nothing = next (record tree {root = Just (leafNode k1 value) }) +... | Just n2 = clearSingleLinkedStack (nodeStack tree) (\ s @$\rightarrow$@ findNode tree s (leafNode k1 value) n2 (\ tree1 s n1 @$\rightarrow$@ insertNode tree1 s n1 next)) + +getRedBlackTree : {n m : Level } {a k : Set n} {t : Set m} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ k @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ (Maybe (Node a k)) @$\rightarrow$@ t) @$\rightarrow$@ t +getRedBlackTree {_} {_} {a} {k} {t} tree k1 cs = checkNode (root tree) + module GetRedBlackTree where -- http://agda.readthedocs.io/en/v2.5.2/language/let-and-where.html + search : Node a k @$\rightarrow$@ t + checkNode : Maybe (Node a k) @$\rightarrow$@ t + checkNode Nothing = cs tree Nothing + checkNode (Just n) = search n + search n with compare tree k1 (key n) + search n | LT = checkNode (left n) + search n | GT = checkNode (right n) + search n | EQ = cs tree (Just n) + +open import Data.Nat hiding (compare) + +compare@$\mathbb{N}$@ : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ CompareResult {Level.zero} +compare@$\mathbb{N}$@ x y with Data.Nat.compare x y +... | less _ _ = LT +... | equal _ = EQ +... | greater _ _ = GT + +compare2 : (x y : @$\mathbb{N}$@ ) @$\rightarrow$@ CompareResult {Level.zero} +compare2 zero zero = EQ +compare2 (suc _) zero = GT +compare2 zero (suc _) = LT +compare2 (suc x) (suc y) = compare2 x y + + +createEmptyRedBlackTree@$\mathbb{N}$@ : { m : Level } (a : Set Level.zero) {t : Set m} @$\rightarrow$@ RedBlackTree {Level.zero} {m} {t} a @$\mathbb{N}$@ +createEmptyRedBlackTree@$\mathbb{N}$@ {m} a {t} = record { + root = Nothing + ; nodeStack = emptySingleLinkedStack + ; compare = compare2 + } +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/RelOp.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,81 @@ +{-# OPTIONS --universe-polymorphism #-} + +open import Level +open import Data.Empty +open import Data.Product +open import Data.Nat.Base +open import Data.Sum +open import Data.Unit +open import Relation.Binary +open import Relation.Binary.Core +open import Relation.Nullary +open import utilities + +module RelOp (S : Set) where + +data Id {l} {X : Set} : Rel X l where + ref : {x : X} -> Id x x + +-- substId1 | x == y & P(x) => P(y) +substId1 : ∀ {l} -> {X : Set} -> {x y : X} -> + Id {l} x y -> (P : Pred X) -> P x -> P y +substId1 ref P q = q + +-- substId2 | x == y & P(y) => P(x) +substId2 : ∀ {l} -> {X : Set} -> {x y : X} -> + Id {l} x y -> (P : Pred X) -> P y -> P x +substId2 ref P q = q + +-- for X ⊆ S (formally, X : Pred S) +-- delta X = { (a, a) | a ∈ X } +delta : ∀ {l} -> Pred S -> Rel S l +delta X a b = X a × Id a b + +-- deltaGlob = delta S +deltaGlob : ∀ {l} -> Rel S l +deltaGlob = delta (λ (s : S) → ⊤) + +-- emptyRel = \varnothing +emptyRel : Rel S Level.zero +emptyRel a b = ⊥ + +-- comp R1 R2 = R2 ∘ R1 (= R1; R2) +comp : ∀ {l} -> Rel S l -> Rel S l -> Rel S l +comp R1 R2 a b = ∃ (λ (a' : S) → R1 a a' × R2 a' b) + +-- union R1 R2 = R1 ∪ R2 +union : ∀ {l} -> Rel S l -> Rel S l -> Rel S l +union R1 R2 a b = R1 a b ⊎ R2 a b + +-- repeat n R = R^n +repeat : ∀ {l} -> ℕ -> Rel S l -> Rel S l +repeat ℕ.zero R = deltaGlob +repeat (ℕ.suc m) R = comp (repeat m R) R + +-- unionInf f = ⋃_{n ∈ ω} f(n) +unionInf : ∀ {l} -> (ℕ -> Rel S l) -> Rel S l +unionInf f a b = ∃ (λ (n : ℕ) → f n a b) +-- restPre X R = { (s1,s2) ∈ R | s1 ∈ X } +restPre : ∀ {l} -> Pred S -> Rel S l -> Rel S l +restPre X R a b = X a × R a b + +-- restPost X R = { (s1,s2) ∈ R | s2 ∈ X } +restPost : ∀ {l} -> Pred S -> Rel S l -> Rel S l +restPost X R a b = R a b × X b + +deltaRestPre : (X : Pred S) -> (R : Rel S Level.zero) -> (a b : S) -> + Iff (restPre X R a b) (comp (delta X) R a b) +deltaRestPre X R a b + = (λ (h : restPre X R a b) → a , (proj₁ h , ref) , proj₂ h) , + λ (h : comp (delta X) R a b) → proj₁ (proj₁ (proj₂ h)) , + substId2 + (proj₂ (proj₁ (proj₂ h))) + (λ z → R z b) (proj₂ (proj₂ h)) + +deltaRestPost : (X : Pred S) -> (R : Rel S Level.zero) -> (a b : S) -> + Iff (restPost X R a b) (comp R (delta X) a b) +deltaRestPost X R a b + = (λ (h : restPost X R a b) → b , proj₁ h , proj₂ h , ref) , + λ (h : comp R (delta X) a b) → + substId1 (proj₂ (proj₂ (proj₂ h))) (R a) (proj₁ (proj₂ h)) , + substId1 (proj₂ (proj₂ (proj₂ h))) X (proj₁ (proj₂ (proj₂ h)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/RelOp.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,81 @@ +{-@$\#$@ OPTIONS --universe-polymorphism @$\#$@-} + +open import Level +open import Data.Empty +open import Data.Product +open import Data.Nat.Base +open import Data.Sum +open import Data.Unit +open import Relation.Binary +open import Relation.Binary.Core +open import Relation.Nullary +open import utilities + +module RelOp (S : Set) where + +data Id {l} {X : Set} : Rel X l where + ref : {x : X} @$\rightarrow$@ Id x x + +-- substId1 | x == y & P(x) => P(y) +substId1 : @$\forall$@ {l} @$\rightarrow$@ {X : Set} @$\rightarrow$@ {x y : X} @$\rightarrow$@ + Id {l} x y @$\rightarrow$@ (P : Pred X) @$\rightarrow$@ P x @$\rightarrow$@ P y +substId1 ref P q = q + +-- substId2 | x == y & P(y) => P(x) +substId2 : @$\forall$@ {l} @$\rightarrow$@ {X : Set} @$\rightarrow$@ {x y : X} @$\rightarrow$@ + Id {l} x y @$\rightarrow$@ (P : Pred X) @$\rightarrow$@ P y @$\rightarrow$@ P x +substId2 ref P q = q + +-- for X ⊆ S (formally, X : Pred S) +-- delta X = { (a, a) | a ∈ X } +delta : @$\forall$@ {l} @$\rightarrow$@ Pred S @$\rightarrow$@ Rel S l +delta X a b = X a @$\times$@ Id a b + +-- deltaGlob = delta S +deltaGlob : @$\forall$@ {l} @$\rightarrow$@ Rel S l +deltaGlob = delta (@$\lambda$@ (s : S) @$\rightarrow$@ @$\top$@) + +-- emptyRel = \varnothing +emptyRel : Rel S Level.zero +emptyRel a b = @$\bot$@ + +-- comp R1 R2 = R2 ∘ R1 (= R1; R2) +comp : @$\forall$@ {l} @$\rightarrow$@ Rel S l @$\rightarrow$@ Rel S l @$\rightarrow$@ Rel S l +comp R1 R2 a b = ∃ (@$\lambda$@ (a' : S) @$\rightarrow$@ R1 a a' @$\times$@ R2 a' b) + +-- union R1 R2 = R1 ∪ R2 +union : @$\forall$@ {l} @$\rightarrow$@ Rel S l @$\rightarrow$@ Rel S l @$\rightarrow$@ Rel S l +union R1 R2 a b = R1 a b ⊎ R2 a b + +-- repeat n R = R^n +repeat : @$\forall$@ {l} @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ Rel S l @$\rightarrow$@ Rel S l +repeat @$\mathbb{N}$@.zero R = deltaGlob +repeat (@$\mathbb{N}$@.suc m) R = comp (repeat m R) R + +-- unionInf f = ⋃_{n ∈ ω} f(n) +unionInf : @$\forall$@ {l} @$\rightarrow$@ (@$\mathbb{N}$@ @$\rightarrow$@ Rel S l) @$\rightarrow$@ Rel S l +unionInf f a b = ∃ (@$\lambda$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ f n a b) +-- restPre X R = { (s1,s2) ∈ R | s1 ∈ X } +restPre : @$\forall$@ {l} @$\rightarrow$@ Pred S @$\rightarrow$@ Rel S l @$\rightarrow$@ Rel S l +restPre X R a b = X a @$\times$@ R a b + +-- restPost X R = { (s1,s2) ∈ R | s2 ∈ X } +restPost : @$\forall$@ {l} @$\rightarrow$@ Pred S @$\rightarrow$@ Rel S l @$\rightarrow$@ Rel S l +restPost X R a b = R a b @$\times$@ X b + +deltaRestPre : (X : Pred S) @$\rightarrow$@ (R : Rel S Level.zero) @$\rightarrow$@ (a b : S) @$\rightarrow$@ + Iff (restPre X R a b) (comp (delta X) R a b) +deltaRestPre X R a b + = (@$\lambda$@ (h : restPre X R a b) @$\rightarrow$@ a , (proj@$\_{1}$@ h , ref) , proj@$\_{2}$@ h) , + @$\lambda$@ (h : comp (delta X) R a b) @$\rightarrow$@ proj@$\_{1}$@ (proj@$\_{1}$@ (proj@$\_{2}$@ h)) , + substId2 + (proj@$\_{2}$@ (proj@$\_{1}$@ (proj@$\_{2}$@ h))) + (@$\lambda$@ z @$\rightarrow$@ R z b) (proj@$\_{2}$@ (proj@$\_{2}$@ h)) + +deltaRestPost : (X : Pred S) @$\rightarrow$@ (R : Rel S Level.zero) @$\rightarrow$@ (a b : S) @$\rightarrow$@ + Iff (restPost X R a b) (comp R (delta X) a b) +deltaRestPost X R a b + = (@$\lambda$@ (h : restPost X R a b) @$\rightarrow$@ b , proj@$\_{1}$@ h , proj@$\_{2}$@ h , ref) , + @$\lambda$@ (h : comp R (delta X) a b) @$\rightarrow$@ + substId1 (proj@$\_{2}$@ (proj@$\_{2}$@ (proj@$\_{2}$@ h))) (R a) (proj@$\_{1}$@ (proj@$\_{2}$@ h)) , + substId1 (proj@$\_{2}$@ (proj@$\_{2}$@ (proj@$\_{2}$@ h))) X (proj@$\_{1}$@ (proj@$\_{2}$@ (proj@$\_{2}$@ h)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/SingleLinkedStack.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,110 @@ +#include "../context.h" +#include "../origin_cs.h" +#include <stdio.h> + +// typedef struct SingleLinkedStack { +// struct Element* top; +// } SingleLinkedStack; + +Stack* createSingleLinkedStack(struct Context* context) { + struct Stack* stack = new Stack(); + struct SingleLinkedStack* singleLinkedStack = new SingleLinkedStack(); + stack->stack = (union Data*)singleLinkedStack; + singleLinkedStack->top = NULL; + stack->push = C_pushSingleLinkedStack; + stack->pop = C_popSingleLinkedStack; + stack->pop2 = C_pop2SingleLinkedStack; + stack->get = C_getSingleLinkedStack; + stack->get2 = C_get2SingleLinkedStack; + stack->isEmpty = C_isEmptySingleLinkedStack; + stack->clear = C_clearSingleLinkedStack; + return stack; +} + +void printStack1(union Data* data) { + struct Node* node = &data->Element.data->Node; + if (node == NULL) { + printf("NULL"); + } else { + printf("key = %d ,", node->key); + printStack1((union Data*)data->Element.next); + } +} + +void printStack(union Data* data) { + printStack1(data); + printf("\n"); +} + +__code clearSingleLinkedStack(struct SingleLinkedStack* stack,__code next(...)) { + stack->top = NULL; + goto next(...); +} + +__code pushSingleLinkedStack(struct SingleLinkedStack* stack,union Data* data, __code next(...)) { + Element* element = new Element(); + element->next = stack->top; + element->data = data; + stack->top = element; + goto next(...); +} + +__code popSingleLinkedStack(struct SingleLinkedStack* stack, __code next(union Data* data, ...)) { + if (stack->top) { + data = stack->top->data; + stack->top = stack->top->next; + } else { + data = NULL; + } + goto next(data, ...); +} + +__code pop2SingleLinkedStack(struct SingleLinkedStack* stack, __code next(union Data* data, union Data* data1, ...)) { + if (stack->top) { + data = stack->top->data; + stack->top = stack->top->next; + } else { + data = NULL; + } + if (stack->top) { + data1 = stack->top->data; + stack->top = stack->top->next; + } else { + data1 = NULL; + } + goto next(data, data1, ...); +} + + +__code getSingleLinkedStack(struct SingleLinkedStack* stack, __code next(union Data* data, ...)) { + if (stack->top) + data = stack->top->data; + else + data = NULL; + goto next(data, ...); +} + +__code get2SingleLinkedStack(struct SingleLinkedStack* stack, __code next(union Data* data, union Data* data1, ...)) { + if (stack->top) { + data = stack->top->data; + if (stack->top->next) { + data1 = stack->top->next->data; + } else { + data1 = NULL; + } + } else { + data = NULL; + data1 = NULL; + } + goto next(data, data1, ...); +} + +__code isEmptySingleLinkedStack(struct SingleLinkedStack* stack, __code next(...), __code whenEmpty(...)) { + if (stack->top) + goto next(...); + else + goto whenEmpty(...); +} + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/Stack.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,14 @@ +typedef struct Stack<Impl>{ + union Data* stack; + union Data* data; + union Data* data1; + __code whenEmpty(...); + __code clear(Impl* stack,__code next(...)); + __code push(Impl* stack,union Data* data, __code next(...)); + __code pop(Impl* stack, __code next(union Data*, ...)); + __code pop2(Impl* stack, union Data** data, union Data** data1, __code next(union Data**, union Data**, ...)); + __code isEmpty(Impl* stack, __code next(...), __code whenEmpty(...)); + __code get(Impl* stack, union Data** data, __code next(...)); + __code get2(Impl* stack,..., __code next(...)); + __code next(...); +} Stack;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/ThreePlusOne.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +open import Relation.Binary.PropositionalEquality +open import nat +open import nat_add + +module three_plus_one where + +3+1 : (S (S (S O))) + (S O) ≡ (S (S (S (S O)))) +3+1 = refl \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/ThreePlusOne.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +open import Relation.Binary.PropositionalEquality +open import nat +open import nat_add + +module three_plus_one where + +3+1 : (S (S (S O))) + (S O) @$\equiv$@ (S (S (S (S O)))) +3+1 = refl \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-func.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ ++1 : ℕ → ℕ ++1 m = suc m
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-func.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ ++1 : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ ++1 m = suc m
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-interpret.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,13 @@ +{-# TERMINATING #-} +interpret : Env → Comm → Env +interpret env Skip = env +interpret env Abort = env +interpret env (PComm x) = x env +interpret env (Seq comm comm1) = interpret (interpret env comm) comm1 +interpret env (If x then else) with x env +... | true = interpret env then +... | false = interpret env else +interpret env (While x comm) with x env +... | true = interpret (interpret env comm) (While x comm) +... | false = env +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-interpret.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,13 @@ +{-@$\#$@ TERMINATING @$\#$@-} +interpret : Env @$\rightarrow$@ Comm @$\rightarrow$@ Env +interpret env Skip = env +interpret env Abort = env +interpret env (PComm x) = x env +interpret env (Seq comm comm1) = interpret (interpret env comm) comm1 +interpret env (If x then else) with x env +... | true = interpret env then +... | false = interpret env else +interpret env (While x comm) with x env +... | true = interpret (interpret env comm) (While x comm) +... | false = env +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-prog.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +program : Comm +program = + Seq ( PComm (λ env → record env {varn = 10})) + $ Seq ( PComm (λ env → record env {vari = 0})) + $ While (λ env → lt zero (varn env ) ) + (Seq (PComm (λ env → record env {vari = ((vari env) + 1)} )) + $ PComm (λ env → record env {varn = ((varn env) - 1)} ))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-prog.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +program : Comm +program = + Seq ( PComm (@$\lambda$@ env @$\rightarrow$@ record env {varn = 10})) + $ Seq ( PComm (@$\lambda$@ env @$\rightarrow$@ record env {vari = 0})) + $ While (@$\lambda$@ env @$\rightarrow$@ lt zero (varn env ) ) + (Seq (PComm (@$\lambda$@ env @$\rightarrow$@ record env {vari = ((vari env) + 1)} )) + $ PComm (@$\lambda$@ env @$\rightarrow$@ record env {varn = ((varn env) - 1)} ))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-rule.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,27 @@ +data HTProof : Cond -> Comm -> Cond -> Set where + PrimRule : {bPre : Cond} -> {pcm : PrimComm} -> {bPost : Cond} -> + (pr : Axiom bPre pcm bPost) -> + HTProof bPre (PComm pcm) bPost + SkipRule : (b : Cond) -> HTProof b Skip b + AbortRule : (bPre : Cond) -> (bPost : Cond) -> + HTProof bPre Abort bPost + WeakeningRule : {bPre : Cond} -> {bPre' : Cond} -> {cm : Comm} -> + {bPost' : Cond} -> {bPost : Cond} -> + Tautology bPre bPre' -> + HTProof bPre' cm bPost' -> + Tautology bPost' bPost -> + HTProof bPre cm bPost + SeqRule : {bPre : Cond} -> {cm1 : Comm} -> {bMid : Cond} -> + {cm2 : Comm} -> {bPost : Cond} -> + HTProof bPre cm1 bMid -> + HTProof bMid cm2 bPost -> + HTProof bPre (Seq cm1 cm2) bPost + IfRule : {cmThen : Comm} -> {cmElse : Comm} -> + {bPre : Cond} -> {bPost : Cond} -> + {b : Cond} -> + HTProof (bPre /\ b) cmThen bPost -> + HTProof (bPre /\ neg b) cmElse bPost -> + HTProof bPre (If b cmThen cmElse) bPost + WhileRule : {cm : Comm} -> {bInv : Cond} -> {b : Cond} -> + HTProof (bInv /\ b) cm bInv -> + HTProof bInv (While b cm) (bInv /\ neg b)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-rule.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,27 @@ +data HTProof : Cond @$\rightarrow$@ Comm @$\rightarrow$@ Cond @$\rightarrow$@ Set where + PrimRule : {bPre : Cond} @$\rightarrow$@ {pcm : PrimComm} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + (pr : Axiom bPre pcm bPost) @$\rightarrow$@ + HTProof bPre (PComm pcm) bPost + SkipRule : (b : Cond) @$\rightarrow$@ HTProof b Skip b + AbortRule : (bPre : Cond) @$\rightarrow$@ (bPost : Cond) @$\rightarrow$@ + HTProof bPre Abort bPost + WeakeningRule : {bPre : Cond} @$\rightarrow$@ {bPre' : Cond} @$\rightarrow$@ {cm : Comm} @$\rightarrow$@ + {bPost' : Cond} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + Tautology bPre bPre' @$\rightarrow$@ + HTProof bPre' cm bPost' @$\rightarrow$@ + Tautology bPost' bPost @$\rightarrow$@ + HTProof bPre cm bPost + SeqRule : {bPre : Cond} @$\rightarrow$@ {cm1 : Comm} @$\rightarrow$@ {bMid : Cond} @$\rightarrow$@ + {cm2 : Comm} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + HTProof bPre cm1 bMid @$\rightarrow$@ + HTProof bMid cm2 bPost @$\rightarrow$@ + HTProof bPre (Seq cm1 cm2) bPost + IfRule : {cmThen : Comm} @$\rightarrow$@ {cmElse : Comm} @$\rightarrow$@ + {bPre : Cond} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + {b : Cond} @$\rightarrow$@ + HTProof (bPre @$\wedge$@ b) cmThen bPost @$\rightarrow$@ + HTProof (bPre @$\wedge$@ neg b) cmElse bPost @$\rightarrow$@ + HTProof bPre (If b cmThen cmElse) bPost + WhileRule : {cm : Comm} @$\rightarrow$@ {bInv : Cond} @$\rightarrow$@ {b : Cond} @$\rightarrow$@ + HTProof (bInv @$\wedge$@ b) cm bInv @$\rightarrow$@ + HTProof bInv (While b cm) (bInv @$\wedge$@ neg b)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-satisfies.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,25 @@ +SemComm : Comm -> Rel State (Level.zero) +SemComm Skip = RelOpState.deltaGlob +SemComm Abort = RelOpState.emptyRel +SemComm (PComm pc) = PrimSemComm pc +SemComm (Seq c1 c2) = RelOpState.comp (SemComm c1) (SemComm c2) +SemComm (If b c1 c2) + = RelOpState.union + (RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm c1)) + (RelOpState.comp (RelOpState.delta (NotP (SemCond b))) + (SemComm c2)) +SemComm (While b c) + = RelOpState.unionInf + (λ (n : $mathbb{N}$) -> + RelOpState.comp (RelOpState.repeat + n + (RelOpState.comp + (RelOpState.delta (SemCond b)) + (SemComm c))) + (RelOpState.delta (NotP (SemCond b)))) + +Satisfies : Cond -> Comm -> Cond -> Set +Satisfies bPre cm bPost + = (s1 : State) -> (s2 : State) -> + SemCond bPre s1 -> SemComm cm s1 s2 -> SemCond bPost s2
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-satisfies.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,25 @@ +SemComm : Comm @$\rightarrow$@ Rel State (Level.zero) +SemComm Skip = RelOpState.deltaGlob +SemComm Abort = RelOpState.emptyRel +SemComm (PComm pc) = PrimSemComm pc +SemComm (Seq c1 c2) = RelOpState.comp (SemComm c1) (SemComm c2) +SemComm (If b c1 c2) + = RelOpState.union + (RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm c1)) + (RelOpState.comp (RelOpState.delta (NotP (SemCond b))) + (SemComm c2)) +SemComm (While b c) + = RelOpState.unionInf + (@$\lambda$@ (n : $mathbb{N}$) @$\rightarrow$@ + RelOpState.comp (RelOpState.repeat + n + (RelOpState.comp + (RelOpState.delta (SemCond b)) + (SemComm c))) + (RelOpState.delta (NotP (SemCond b)))) + +Satisfies : Cond @$\rightarrow$@ Comm @$\rightarrow$@ Cond @$\rightarrow$@ Set +Satisfies bPre cm bPost + = (s1 : State) @$\rightarrow$@ (s2 : State) @$\rightarrow$@ + SemCond bPre s1 @$\rightarrow$@ SemComm cm s1 s2 @$\rightarrow$@ SemCond bPost s2
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-soundness.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,66 @@ +Soundness : {bPre : Cond} -> {cm : Comm} -> {bPost : Cond} -> + HTProof bPre cm bPost -> Satisfies bPre cm bPost +Soundness (PrimRule {bPre} {cm} {bPost} pr) s1 s2 q1 q2 + = axiomValid bPre cm bPost pr s1 s2 q1 q2 +Soundness {.bPost} {.Skip} {bPost} (SkipRule .bPost) s1 s2 q1 q2 + = substId1 State {Level.zero} {State} {s1} {s2} (proj₂ q2) (SemCond bPost) q1 +Soundness {bPre} {.Abort} {bPost} (AbortRule .bPre .bPost) s1 s2 q1 () +Soundness (WeakeningRule {bPre} {bPre'} {cm} {bPost'} {bPost} tautPre pr tautPost) + s1 s2 q1 q2 + = let hyp : Satisfies bPre' cm bPost' + hyp = Soundness pr + in tautValid bPost' bPost tautPost s2 (hyp s1 s2 (tautValid bPre bPre' tautPre s1 q1) q2) +Soundness (SeqRule {bPre} {cm1} {bMid} {cm2} {bPost} pr1 pr2) + s1 s2 q1 q2 + = let hyp1 : Satisfies bPre cm1 bMid + hyp1 = Soundness pr1 + hyp2 : Satisfies bMid cm2 bPost + hyp2 = Soundness pr2 + in hyp2 (proj₁ q2) s2 (hyp1 s1 (proj₁ q2) q1 (proj₁ (proj₂ q2))) (proj₂ (proj₂ q2)) +Soundness (IfRule {cmThen} {cmElse} {bPre} {bPost} {b} pThen pElse) + s1 s2 q1 q2 + = let hypThen : Satisfies (bPre /\ b) cmThen bPost + hypThen = Soundness pThen + hypElse : Satisfies (bPre /\ neg b) cmElse bPost + hypElse = Soundness pElse + rThen : RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm cmThen) s1 s2 -> SemCond bPost s2 + rThen = λ h -> hypThen s1 s2 ((proj₂ (respAnd bPre b s1)) (q1 , proj₁ t1)) + (proj₂ ((proj₂ (RelOpState.deltaRestPre (SemCond b) (SemComm cmThen) s1 s2)) h)) + rElse : RelOpState.comp (RelOpState.delta (NotP (SemCond b))) + (SemComm cmElse) s1 s2 -> SemCond bPost s2 + rElse = λ h -> + let t10 : (NotP (SemCond b) s1) × (SemComm cmElse s1 s2) + t10 = proj₂ (RelOpState.deltaRestPre + (NotP (SemCond b)) (SemComm cmElse) s1 s2) h + in hypElse s1 s2 (proj₂ (respAnd bPre (neg b) s1) + (q1 , (proj₂ (respNeg b s1) (proj₁ t10)))) (proj₂ t10) + in when rThen rElse q2 +Soundness (WhileRule {cm'} {bInv} {b} pr) s1 s2 q1 q2 + = proj₂ (respAnd bInv (neg b) s2) + (lem1 (proj₁ q2) s2 (proj₁ t15) , proj₂ (respNeg b s2) (proj₂ t15)) + where + hyp : Satisfies (bInv /\ b) cm' bInv + hyp = Soundness pr + Rel1 : ℕ -> Rel State (Level.zero) + Rel1 = λ m -> + RelOpState.repeat + m + (RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm cm')) + t15 : (Rel1 (proj₁ q2) s1 s2) × (NotP (SemCond b) s2) + t15 = proj₂ (RelOpState.deltaRestPost + (NotP (SemCond b)) (Rel1 (proj₁ q2)) s1 s2) (proj₂ q2) + lem1 : (m : ℕ) -> (ss2 : State) -> Rel1 m s1 ss2 -> SemCond bInv ss2 + lem1 zero ss2 h = substId1 State (proj₂ h) (SemCond bInv) q1 + lem1 (suc n) ss2 h + = let hyp2 : (z : State) -> Rel1 (proj₁ q2) s1 z -> + SemCond bInv z + hyp2 = lem1 n + t22 : (SemCond b (proj₁ h)) × (SemComm cm' (proj₁ h) ss2) + t22 = proj₂ (RelOpState.deltaRestPre (SemCond b) (SemComm cm') (proj₁ h) ss2) + (proj₂ (proj₂ h)) + t23 : SemCond (bInv /\ b) (proj₁ h) + t23 = proj₂ (respAnd bInv b (proj₁ h)) + (hyp2 (proj₁ h) (proj₁ (proj₂ h)) , proj₁ t22) + in hyp (proj₁ h) ss2 t23 (proj₂ t22)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-soundness.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,66 @@ +Soundness : {bPre : Cond} @$\rightarrow$@ {cm : Comm} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + HTProof bPre cm bPost @$\rightarrow$@ Satisfies bPre cm bPost +Soundness (PrimRule {bPre} {cm} {bPost} pr) s1 s2 q1 q2 + = axiomValid bPre cm bPost pr s1 s2 q1 q2 +Soundness {.bPost} {.Skip} {bPost} (SkipRule .bPost) s1 s2 q1 q2 + = substId1 State {Level.zero} {State} {s1} {s2} (proj@$\_{2}$@ q2) (SemCond bPost) q1 +Soundness {bPre} {.Abort} {bPost} (AbortRule .bPre .bPost) s1 s2 q1 () +Soundness (WeakeningRule {bPre} {bPre'} {cm} {bPost'} {bPost} tautPre pr tautPost) + s1 s2 q1 q2 + = let hyp : Satisfies bPre' cm bPost' + hyp = Soundness pr + in tautValid bPost' bPost tautPost s2 (hyp s1 s2 (tautValid bPre bPre' tautPre s1 q1) q2) +Soundness (SeqRule {bPre} {cm1} {bMid} {cm2} {bPost} pr1 pr2) + s1 s2 q1 q2 + = let hyp1 : Satisfies bPre cm1 bMid + hyp1 = Soundness pr1 + hyp2 : Satisfies bMid cm2 bPost + hyp2 = Soundness pr2 + in hyp2 (proj@$\_{1}$@ q2) s2 (hyp1 s1 (proj@$\_{1}$@ q2) q1 (proj@$\_{1}$@ (proj@$\_{2}$@ q2))) (proj@$\_{2}$@ (proj@$\_{2}$@ q2)) +Soundness (IfRule {cmThen} {cmElse} {bPre} {bPost} {b} pThen pElse) + s1 s2 q1 q2 + = let hypThen : Satisfies (bPre @$\wedge$@ b) cmThen bPost + hypThen = Soundness pThen + hypElse : Satisfies (bPre @$\wedge$@ neg b) cmElse bPost + hypElse = Soundness pElse + rThen : RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm cmThen) s1 s2 @$\rightarrow$@ SemCond bPost s2 + rThen = @$\lambda$@ h @$\rightarrow$@ hypThen s1 s2 ((proj@$\_{2}$@ (respAnd bPre b s1)) (q1 , proj@$\_{1}$@ t1)) + (proj@$\_{2}$@ ((proj@$\_{2}$@ (RelOpState.deltaRestPre (SemCond b) (SemComm cmThen) s1 s2)) h)) + rElse : RelOpState.comp (RelOpState.delta (NotP (SemCond b))) + (SemComm cmElse) s1 s2 @$\rightarrow$@ SemCond bPost s2 + rElse = @$\lambda$@ h @$\rightarrow$@ + let t10 : (NotP (SemCond b) s1) @$\times$@ (SemComm cmElse s1 s2) + t10 = proj@$\_{2}$@ (RelOpState.deltaRestPre + (NotP (SemCond b)) (SemComm cmElse) s1 s2) h + in hypElse s1 s2 (proj@$\_{2}$@ (respAnd bPre (neg b) s1) + (q1 , (proj@$\_{2}$@ (respNeg b s1) (proj@$\_{1}$@ t10)))) (proj@$\_{2}$@ t10) + in when rThen rElse q2 +Soundness (WhileRule {cm'} {bInv} {b} pr) s1 s2 q1 q2 + = proj@$\_{2}$@ (respAnd bInv (neg b) s2) + (lem1 (proj@$\_{1}$@ q2) s2 (proj@$\_{1}$@ t15) , proj@$\_{2}$@ (respNeg b s2) (proj@$\_{2}$@ t15)) + where + hyp : Satisfies (bInv @$\wedge$@ b) cm' bInv + hyp = Soundness pr + Rel1 : @$\mathbb{N}$@ @$\rightarrow$@ Rel State (Level.zero) + Rel1 = @$\lambda$@ m @$\rightarrow$@ + RelOpState.repeat + m + (RelOpState.comp (RelOpState.delta (SemCond b)) + (SemComm cm')) + t15 : (Rel1 (proj@$\_{1}$@ q2) s1 s2) @$\times$@ (NotP (SemCond b) s2) + t15 = proj@$\_{2}$@ (RelOpState.deltaRestPost + (NotP (SemCond b)) (Rel1 (proj@$\_{1}$@ q2)) s1 s2) (proj@$\_{2}$@ q2) + lem1 : (m : @$\mathbb{N}$@) @$\rightarrow$@ (ss2 : State) @$\rightarrow$@ Rel1 m s1 ss2 @$\rightarrow$@ SemCond bInv ss2 + lem1 zero ss2 h = substId1 State (proj@$\_{2}$@ h) (SemCond bInv) q1 + lem1 (suc n) ss2 h + = let hyp2 : (z : State) @$\rightarrow$@ Rel1 (proj@$\_{1}$@ q2) s1 z @$\rightarrow$@ + SemCond bInv z + hyp2 = lem1 n + t22 : (SemCond b (proj@$\_{1}$@ h)) @$\times$@ (SemComm cm' (proj@$\_{1}$@ h) ss2) + t22 = proj@$\_{2}$@ (RelOpState.deltaRestPre (SemCond b) (SemComm cm') (proj@$\_{1}$@ h) ss2) + (proj@$\_{2}$@ (proj@$\_{2}$@ h)) + t23 : SemCond (bInv @$\wedge$@ b) (proj@$\_{1}$@ h) + t23 = proj@$\_{2}$@ (respAnd bInv b (proj@$\_{1}$@ h)) + (hyp2 (proj@$\_{1}$@ h) (proj@$\_{1}$@ (proj@$\_{2}$@ h)) , proj@$\_{1}$@ t22) + in hyp (proj@$\_{1}$@ h) ss2 t23 (proj@$\_{2}$@ t22)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-term.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +loopP' : {l : Level} {t : Set l} → Envc → (exit : Envc → t) → t +loopP' record { c10 = c10 ; varn = zero ; vari = vari } exit = + exit (record { c10 = c10 ; varn = zero ; vari = vari }) +loopP' record { c10 = c10 ; varn = (suc varn₁) ; vari = vari } exit = + whileLoopP' (record { c10 = c10 ; varn = (suc varn₁) ; vari = vari }) + (λ env → loopP' (record { c10 = c10 ; varn = varn₁ ; vari = vari }) exit ) exit + +whileTestPCall' : (c10 : ℕ ) → Envc +whileTestPCall' c10 = whileTestP' {_} {_} c10 (λ env → loopP' env (λ env → env)) + +-- whileTestP' 10 +-- record { c10 = 10 ; varn = 0 ; vari = 10 }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-term.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +loopP' : {l : Level} {t : Set l} @$\rightarrow$@ Envc @$\rightarrow$@ (exit : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +loopP' record { c10 = c10 ; varn = zero ; vari = vari } exit = + exit (record { c10 = c10 ; varn = zero ; vari = vari }) +loopP' record { c10 = c10 ; varn = (suc varn@$\_{1}$@) ; vari = vari } exit = + whileLoopP' (record { c10 = c10 ; varn = (suc varn@$\_{1}$@) ; vari = vari }) + (@$\lambda$@ env @$\rightarrow$@ loopP' (record { c10 = c10 ; varn = varn@$\_{1}$@ ; vari = vari }) exit ) exit + +whileTestPCall' : (c10 : @$\mathbb{N}$@ ) @$\rightarrow$@ Envc +whileTestPCall' c10 = whileTestP' {_} {_} c10 (@$\lambda$@ env @$\rightarrow$@ loopP' env (@$\lambda$@ env @$\rightarrow$@ env)) + +-- whileTestP' 10 +-- record { c10 = 10 ; varn = 0 ; vari = 10 }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-while.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +proof1 : HTProof initCond program termCond +proof1 = + SeqRule {λ e → true} ( PrimRule empty-case ) + $ SeqRule {λ e → Equal (varn e) 10} ( PrimRule lemma1 ) + $ WeakeningRule {λ e → (Equal (varn e) 10) ∧ (Equal (vari e) 0)} lemma2 ( + WhileRule {_} {λ e → Equal ((varn e) + (vari e)) 10} + $ SeqRule (PrimRule {λ e → whileInv e ∧ lt zero (varn e) } lemma3 ) + $ PrimRule {whileInv'} {_} {whileInv} lemma4 ) lemma5
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-while.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +proof1 : HTProof initCond program termCond +proof1 = + SeqRule {@$\lambda$@ e @$\rightarrow$@ true} ( PrimRule empty-case ) + $ SeqRule {@$\lambda$@ e @$\rightarrow$@ Equal (varn e) 10} ( PrimRule lemma1 ) + $ WeakeningRule {@$\lambda$@ e @$\rightarrow$@ (Equal (varn e) 10) @$\wedge$@ (Equal (vari e) 0)} lemma2 ( + WhileRule {_} {@$\lambda$@ e @$\rightarrow$@ Equal ((varn e) + (vari e)) 10} + $ SeqRule (PrimRule {@$\lambda$@ e @$\rightarrow$@ whileInv e @$\wedge$@ lt zero (varn e) } lemma3 ) + $ PrimRule {whileInv'} {_} {whileInv} lemma4 ) lemma5
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-whileprog.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,16 @@ +whileTestP : {l : Level} {t : Set l} → (c10 : ℕ) → (Code : Envc → t) → t +whileTestP c10 next = next (record {c10 = c10 ; varn = c10 ; vari = 0 }) + +whileLoopP' : {l : Level} {t : Set l} → Envc → (next : Envc → t) → (exit : Envc → t) → t +whileLoopP' record { c10 = c10 ; varn = zero ; vari = vari } _ exit = exit record { c10 = c10 ; varn = zero ; vari = vari } +whileLoopP' record { c10 = c10 ; varn = suc varn1 ; vari = vari } next _ = next (record {c10 = c10 ; varn = varn1 ; vari = suc vari }) + +{-# TERMINATING #-} +loopP : {l : Level} {t : Set l} → Envc → (exit : Envc → t) → t +loopP env exit = whileLoopP' env (λ env → loopP env exit ) exit + +whileTestPCall : (c10 : ℕ ) → Envc +whileTestPCall c10 = whileTestP {_} {_} c10 (λ env → loopP env (λ env → env)) + +-- whileTestPCall 10 +-- record { c10 = 10 ; varn = 0 ; vari = 10 }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-whileprog.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,16 @@ +whileTestP : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ (Code : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +whileTestP c10 next = next (record {c10 = c10 ; varn = c10 ; vari = 0 }) + +whileLoopP' : {l : Level} {t : Set l} @$\rightarrow$@ Envc @$\rightarrow$@ (next : Envc @$\rightarrow$@ t) @$\rightarrow$@ (exit : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopP' record { c10 = c10 ; varn = zero ; vari = vari } _ exit = exit record { c10 = c10 ; varn = zero ; vari = vari } +whileLoopP' record { c10 = c10 ; varn = suc varn1 ; vari = vari } next _ = next (record {c10 = c10 ; varn = varn1 ; vari = suc vari }) + +{-@$\#$@ TERMINATING @$\#$@-} +loopP : {l : Level} {t : Set l} @$\rightarrow$@ Envc @$\rightarrow$@ (exit : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +loopP env exit = whileLoopP' env (@$\lambda$@ env @$\rightarrow$@ loopP env exit ) exit + +whileTestPCall : (c10 : @$\mathbb{N}$@ ) @$\rightarrow$@ Envc +whileTestPCall c10 = whileTestP {_} {_} c10 (@$\lambda$@ env @$\rightarrow$@ loopP env (@$\lambda$@ env @$\rightarrow$@ env)) + +-- whileTestPCall 10 +-- record { c10 = 10 ; varn = 0 ; vari = 10 }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-write.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +-- Nomal CodeGear +whileLoop' : {l : Level} {t : Set l} → (n : ℕ) → (env : Envc) + → (n ≡ varn env) + → (next : Envc → t) + → (exit : Envc → t) → t +whileLoop' zero env refl _ exit = exit env +whileLoop' (suc n) env refl next _ = next (record env {varn = pred (varn env) ; vari = suc (vari env) }) + +-- Hoare Logic base CodeGear +whileLoopPwP' : {l : Level} {t : Set l} → (n : ℕ) → (env : Envc ) + → (n ≡ varn env) → (pre : varn env + vari env ≡ c10 env) + → (next : (env : Envc ) → (pred n ≡ varn env) → (post : varn env + vari env ≡ c10 env) → t) + → (exit : (env : Envc ) → (fin : vari env ≡ c10 env) → t) → t +whileLoopPwP' zero env refl refl next exit = exit env refl +whileLoopPwP' (suc n) env refl refl next exit = next (record env {varn = pred (varn env) ; vari = suc (vari env) }) refl (+-suc n (vari env))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-hoare-write.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +-- Nomal CodeGear +whileLoop' : {l : Level} {t : Set l} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc) + @$\rightarrow$@ (n @$\equiv$@ varn env) + @$\rightarrow$@ (next : Envc @$\rightarrow$@ t) + @$\rightarrow$@ (exit : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoop' zero env refl _ exit = exit env +whileLoop' (suc n) env refl next _ = next (record env {varn = pred (varn env) ; vari = suc (vari env) }) + +-- Hoare Logic base CodeGear +whileLoopPwP' : {l : Level} {t : Set l} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc ) + @$\rightarrow$@ (n @$\equiv$@ varn env) @$\rightarrow$@ (pre : varn env + vari env @$\equiv$@ c10 env) + @$\rightarrow$@ (next : (env : Envc ) @$\rightarrow$@ (pred n @$\equiv$@ varn env) @$\rightarrow$@ (post : varn env + vari env @$\equiv$@ c10 env) @$\rightarrow$@ t) + @$\rightarrow$@ (exit : (env : Envc ) @$\rightarrow$@ (fin : vari env @$\equiv$@ c10 env) @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopPwP' zero env refl refl next exit = exit env refl +whileLoopPwP' (suc n) env refl refl next exit = next (record env {varn = pred (varn env) ; vari = suc (vari env) }) refl (+-suc n (vari env))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-mcg.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +whileTestPwP : {l : Level} {t : Set l} → (c10 : ℕ) → + ((env : Envc ) → (mdg : (vari env ≡ 0) /\ (varn env ≡ c10 env)) → t) → t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( λ env → env )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-mcg.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +whileTestPwP : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ + ((env : Envc ) @$\rightarrow$@ (mdg : (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env)) @$\rightarrow$@ t) @$\rightarrow$@ t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( @$\lambda$@ env @$\rightarrow$@ env )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-mdg.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +data whileTestState : Set where + s1 : whileTestState + s2 : whileTestState + sf : whileTestState + + +whileTestStateP : whileTestState → Envc → Set +whileTestStateP s1 env = (vari env ≡ 0) /\ (varn env ≡ c10 env) +whileTestStateP s2 env = (varn env + vari env ≡ c10 env) +whileTestStateP sf env = (vari env ≡ c10 env)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-mdg.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +data whileTestState : Set where + s1 : whileTestState + s2 : whileTestState + sf : whileTestState + + +whileTestStateP : whileTestState @$\rightarrow$@ Envc @$\rightarrow$@ Set +whileTestStateP s1 env = (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) +whileTestStateP s2 env = (varn env + vari env @$\equiv$@ c10 env) +whileTestStateP sf env = (vari env @$\equiv$@ c10 env)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-pattern.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +_-_ : Nat → Nat → Nat +n - zero = n +zero - suc m = zero +suc n - suc m = n - m
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-pattern.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +_-_ : Nat @$\rightarrow$@ Nat @$\rightarrow$@ Nat +n - zero = n +zero - suc m = zero +suc n - suc m = n - m
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-plus.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +_+_ : ℕ → ℕ → ℕ +zero + m = m +suc n + m = suc (n + m)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-plus.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +_+_ : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ +zero + m = m +suc n + m = suc (n + m)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-rewrite.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +rewrite-+-comm : (x y : ℕ) → x + y ≡ y + x +rewrite-+-comm zero y rewrite (+zero {y}) = refl +rewrite-+-comm (suc x) y = ?
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-rewrite.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +rewrite-+-comm : (x y : @$\mathbb{N}$@) @$\rightarrow$@ x + y @$\equiv$@ y + x +rewrite-+-comm zero y rewrite (+zero {y}) = refl +rewrite-+-comm (suc x) y = ?
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-term.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,28 @@ +module agda-term where + +open import Data.Nat.Base +open import Relation.Binary.PropositionalEquality + ++zero : {y : ℕ} → y + zero ≡ y ++zero {zero} = refl ++zero {suc y} = cong (λ yy → suc yy) (+zero {y}) + ++-suc : {x y : ℕ} → x + suc y ≡ suc (x + y) ++-suc {zero} {y} = refl ++-suc {suc x} {y} = cong suc (+-suc {x} {y}) + ++-comm : (x y : ℕ) → x + y ≡ y + x ++-comm zero y rewrite (+zero {y}) = refl ++-comm (suc x) y = let open ≡-Reasoning in + begin + suc (x + y) ≡⟨⟩ + suc (x + y) ≡⟨ cong suc (+-comm x y) ⟩ + suc (y + x) ≡⟨ sym (+-suc {y} {x}) ⟩ + y + suc x ∎ + ++-come : (x y : ℕ) → x + y ≡ y + x ++-come zero y rewrite (+zero {y}) = refl ++-come (suc x) y + rewrite (cong suc (+-come x y)) | sym (+-suc {y} {x}) = refl + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-term.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,28 @@ +module agda-term where + +open import Data.Nat.Base +open import Relation.Binary.PropositionalEquality + ++zero : {y : @$\mathbb{N}$@} @$\rightarrow$@ y + zero @$\equiv$@ y ++zero {zero} = refl ++zero {suc y} = cong (@$\lambda$@ yy @$\rightarrow$@ suc yy) (+zero {y}) + ++-suc : {x y : @$\mathbb{N}$@} @$\rightarrow$@ x + suc y @$\equiv$@ suc (x + y) ++-suc {zero} {y} = refl ++-suc {suc x} {y} = cong suc (+-suc {x} {y}) + ++-comm : (x y : @$\mathbb{N}$@) @$\rightarrow$@ x + y @$\equiv$@ y + x ++-comm zero y rewrite (+zero {y}) = refl ++-comm (suc x) y = let open @$\equiv$@-Reasoning in + begin + suc (x + y) @$\equiv$@@$\langle$@@$\rangle$@ + suc (x + y) @$\equiv$@@$\langle$@ cong suc (+-comm x y) @$\rangle$@ + suc (y + x) @$\equiv$@@$\langle$@ sym (+-suc {y} {x}) @$\rangle$@ + y + suc x @$\blacksquare$@ + ++-come : (x y : @$\mathbb{N}$@) @$\rightarrow$@ x + y @$\equiv$@ y + x ++-come zero y rewrite (+zero {y}) = refl ++-come (suc x) y + rewrite (cong suc (+-come x y)) | sym (+-suc {y} {x}) = refl + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-term1.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ ++-comm : (x y : ℕ) → x + y ≡ y + x ++-comm zero y rewrite (+zero {y}) = refl ++-comm (suc x) y = let open ≡-Reasoning in + begin + ?0 ≡⟨ ?1 ⟩ + ?2 ∎ + +-- ?0 : ℕ {(suc x) + y} +-- ?1 : suc x + y ≡ y + suc x +-- ?2 : ℕ
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-term1.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ ++-comm : (x y : @$\mathbb{N}$@) @$\rightarrow$@ x + y @$\equiv$@ y + x ++-comm zero y rewrite (+zero {y}) = refl ++-comm (suc x) y = let open @$\equiv$@-Reasoning in + begin + ?0 @$\equiv$@@$\langle$@ ?1 @$\rangle$@ + ?2 @$\blacksquare$@ + +-- ?0 : @$\mathbb{N}$@ {(suc x) + y} +-- ?1 : suc x + y @$\equiv$@ y + suc x +-- ?2 : @$\mathbb{N}$@
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-term2.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ ++-comm : (x y : ℕ) → x + y ≡ y + x ++-comm zero y rewrite (+zero {y}) = refl ++-comm (suc x) y = let open ≡-Reasoning in + begin + (suc x) + y ≡⟨⟩ + suc (x + y) ≡⟨ cong suc (+-comm x y) ⟩ + suc (y + x) ≡⟨ ?0 ⟩ + ?1 ∎ + +-- ?0 : suc (y + x) ≡ y + suc x +-- ?1 : y + suc x
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-term2.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ ++-comm : (x y : @$\mathbb{N}$@) @$\rightarrow$@ x + y @$\equiv$@ y + x ++-comm zero y rewrite (+zero {y}) = refl ++-comm (suc x) y = let open @$\equiv$@-Reasoning in + begin + (suc x) + y @$\equiv$@@$\langle$@@$\rangle$@ + suc (x + y) @$\equiv$@@$\langle$@ cong suc (+-comm x y) @$\rangle$@ + suc (y + x) @$\equiv$@@$\langle$@ ?0 @$\rangle$@ + ?1 @$\blacksquare$@ + +-- ?0 : suc (y + x) @$\equiv$@ y + suc x +-- ?1 : y + suc x
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-term3.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ ++-comm : (x y : ℕ) → x + y ≡ y + x ++-comm zero y rewrite (+zero {y}) = refl ++-comm (suc x) y = let open ≡-Reasoning in + begin + suc (x + y) ≡⟨⟩ + suc (x + y) ≡⟨ cong suc (+-comm x y) ⟩ + suc (y + x) ≡⟨ sym (+-suc {y} {x}) ⟩ + y + suc x ∎ + +-- +-suc : {x y : ℕ} → x + suc y ≡ suc (x + y) +-- +-suc {zero} {y} = refl +-- +-suc {suc x} {y} = cong suc (+-suc {x} {y})
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda-term3.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ ++-comm : (x y : @$\mathbb{N}$@) @$\rightarrow$@ x + y @$\equiv$@ y + x ++-comm zero y rewrite (+zero {y}) = refl ++-comm (suc x) y = let open @$\equiv$@-Reasoning in + begin + suc (x + y) @$\equiv$@@$\langle$@@$\rangle$@ + suc (x + y) @$\equiv$@@$\langle$@ cong suc (+-comm x y) @$\rangle$@ + suc (y + x) @$\equiv$@@$\langle$@ sym (+-suc {y} {x}) @$\rangle$@ + y + suc x @$\blacksquare$@ + +-- +-suc : {x y : @$\mathbb{N}$@} @$\rightarrow$@ x + suc y @$\equiv$@ suc (x + y) +-- +-suc {zero} {y} = refl +-- +-suc {suc x} {y} = cong suc (+-suc {x} {y})
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/.#abridgement.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +soto@Szeleta.local.353 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/.#hoare-test.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +soto@Szeleta.local.353 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/.#plus2.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +soto@Szeleta.local.353 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/And.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +record _∧_ (A B : Set) : Set where + field + p1 : A + p2 : B
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/Nat.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +data ℕ : Set where + zero : ℕ + suc : (n : ℕ) → ℕ
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/abridgement.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,22 @@ +module abridgement where + +open import Data.Nat + +record env : Set where + field + a : ℕ + b : ℕ + c : ℕ +open env + +patternmatch-default : env → ℕ +patternmatch-default record { a = a ; b = b ; c = c } = c + +patternmatch-extraction : env → ℕ +patternmatch-extraction env with c env +patternmatch-extraction env | c = c + +patternmatch-extraction' : env → ℕ +patternmatch-extraction' env with c env +... | c = c +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/cbc-agda.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,22 @@ +module cbc-agda where + +open import Data.Nat +open import Level renaming ( suc to succ ; zero to Zero ) + +record Env : Set where + field + varx : ℕ + vary : ℕ +open Env + +plus-com : {l : Level} {t : Set l} → Env → (next : Env → t) → (exit : Env → t) → t +plus-com env next exit with vary env +... | zero = exit (record { varx = varx env ; vary = vary env }) +... | suc y = next (record { varx = suc (varx env) ; vary = y }) + +{-# TERMINATING #-} +plus-p : {l : Level} {t : Set l} → (env : Env) → (exit : Env → t) → t +plus-p env exit = plus-com env ( λ env → plus-p env exit ) exit + +plus : ℕ → ℕ → Env +plus x y = plus-p (record { varx = x ; vary = y }) (λ env → env)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/cmp.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +module cmp where + +open import Data.Nat +open import Data.Nat.Properties as NatProp -- <-cmp +open import Relation.Binary + +compare_test : ℕ → ℕ → ℕ +compare_test x y with <-cmp x y +... | tri< a ¬b ¬c = y +... | tri≈ ¬a b ¬c = x +... | tri> ¬a ¬b c = x + +-- test = compare_test 7 2 +-- 7 +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/hoare-test.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,105 @@ +module hoare-test where + +open import Data.Nat hiding (_⊔_) +open import Level renaming ( suc to succ ; zero to Zero ) + +open import Relation.Binary +open import Relation.Binary.PropositionalEquality + +open import Relation.Nullary hiding (proof) + +open import Data.Nat.Properties as NatProp -- <-cmp + +record Env : Set where + field + var-init-x : ℕ + var-init-y : ℕ + var-x : ℕ + var-y : ℕ +open Env + +plus-com : {l : Level} {t : Set l} → Env → (next : Env → t) → (exit : Env → t) → t +plus-com env next exit with var-y env +... | zero = exit record env{var-x = var-x env ; var-y = zero} +... | suc y = next record env{var-x = suc (var-x env) ; var-y = y} + +plus-init : {l : Level} {t : Set l} → ( x y : ℕ ) → (next : Env → t) → t +plus-init x y next = next (record { var-init-x = x ; var-init-y = y ; var-x = x ; var-y = y }) + +{-# TERMINATING #-} +plus-p : {l : Level} {t : Set l} → (env : Env) → (exit : Env → t) → t +plus-p env exit = plus-com env ( λ env → plus-p env exit ) exit + +plus : ℕ → ℕ → Env +plus x y = plus-init x y (λ env → plus-p env (λ env → env)) +--(record { varx = x ; vary = y }) (λ env → env) + +-- ここまでplusの定義 + +-- mdg (meta code gear) +data mdg-state : Set where + s-init : mdg-state + s-doing : mdg-state + s-fin : mdg-state + +record _∧_ {n m : Level} (A : Set n) ( B : Set m ) : Set (n ⊔ m) where + field + proj1 : A + proj2 : B + +-- mcg (meta code gear) +plus-mdg : mdg-state → Env → Set +plus-mdg s-init env = (var-x env ≡ var-init-x env) ∧ (var-y env ≡ var-init-y env) +plus-mdg s-doing env = (var-init-x env ≡ var-init-x env) ∧ (var-init-y env ≡ var-init-y env) -- よくないmdg +plus-mdg s-fin env = (var-init-x env ≡ var-init-x env) ∧ (var-init-y env ≡ var-init-y env) -- よくないmdg + +-- 実行のwrapperを作って、そこでmcgが適切に選ばれて接続をしたい。多分できる気がする。 +plus-init-mcg : {l : Level} {t : Set l} → (x y : ℕ) → ((env : Env ) → plus-mdg s-init env → t) → t +plus-init-mcg x y next = next ( plus-init x y ( λ env → env ) ) record { proj1 = refl ; proj2 = refl } where + +plus-com-mcg : {l : Level} {t : Set l} → (env : Env ) → (next : (env : Env ) → plus-mdg s-doing env → t) → (exit : (env : Env ) → plus-mdg s-fin env → t) → t +plus-com-mcg env-in next exit with (var-y env-in) +... | suc y = next ( plus-com env-in ( λ env → env ) ( λ env → env ) ) (record { proj1 = refl ; proj2 = refl }) where +... | zero = exit env-in (record { proj1 = refl ; proj2 = refl }) + +--plus-com-mcg +{-# TERMINATING #-} +plus-p-mcg : {l : Level} {t : Set l} → (env : Env) → (exit : (env : Env ) → plus-mdg s-fin env → t) → t +plus-p-mcg env exit = plus-com-mcg env (λ env s → plus-p-mcg env exit ) exit + +plus-mcg : (x y : ℕ) → Env +plus-mcg x y = plus-init-mcg x y (λ env s → plus-p-mcg env (λ env s → env)) + + + +test1 = plus-mcg 3 4 + +{- +next env ? where + env : Env + env = plus-com env-in {!!} {!!} +-} +--plus-mdg s-init (plus-p record env{var-x = var-init-x env ; var-y = var-init-y env} (λ env → env)) + + + +{- +whileTestPwP : {l : Level} {t : Set l} → (c10 : ℕ) → ((env : Envc ) → whileTestStateP s1 env → t) → t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( λ env → env ) +-} + +data hoare-cond : Set where + p : hoare-cond + q : hoare-cond + + +{- +continuation-hoare-triple : {l : Level} {t : Set l} → hoare-cond → (next : Env → t) Set +continuation-hoare-triple p next = continuation-hoare-triple q +continuation-hoare-triple q next = continuation-hoare-triple p +-} + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/lambda.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,28 @@ +module lambda where + +open import Data.Nat + +ll+_ : (x y : ℕ) → ℕ +ll+ zero = λ y → y +ll+ suc x = λ y → (ll+ x) (suc y) + +test = (ll+ 5) 7 + +-- +1をしたのち、もう一度+1をする関数を定義する場合 + ++1 : (x : ℕ )→ ℕ ++1 x = suc x + ++n : (a : ℕ) → (x : ℕ → ℕ) → ℕ ++n a x = x a + +test*2 : (a : ℕ) → ℕ +test*2 a = +n a (λ z → z + 2) + +test*2' : (a : ℕ) → ℕ +test*2' a = +n a (λ z → +n z (λ z → z)) + + +λ'+2 : (x : ℕ) → ℕ +λ'+2 d = {!!} -- (λ x → x +1) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/plus.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +plus : (x y : ℕ) → ℕ +plus x zero = x +plus x (suc y) = plus (suc x) y + +-- plus 10 20 +-- 30
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/plus2.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +module plus2 where + +open import Data.Nat hiding (_+_) + +_+_ : (x y : ℕ) → ℕ +x + zero = x +x + suc y = (suc x) + y + +-- 10 + 20 +-- 30
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/agda/syllogism.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +syllogism : {A B C : Set} → ((A → B) ∧ (B → C)) → (A → C) +syllogism x a = _∧_.p2 x (_∧_.p1 x a)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/atomicImpl.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +__code checkAndSetAtomicReference(struct AtomicReference* atomic, union Data** ptr, union Data* oldData, union Data* newData, __code next(...), __code fail(...)) { + if (__sync_bool_compare_and_swap(ptr, oldData, newData)) { + goto next(...); + } + goto fail(...); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/atton-master-meta-sample.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,77 @@ +module atton-master-meta-sample where + +open import Data.Nat +open import Data.Unit +open import Function +Int = ℕ + +record Context : Set where + field + a : Int + b : Int + c : Int + +open import subtype Context as N + +record Meta : Set where + field + context : Context + c' : Int + next : N.CodeSegment Context Context + +open import subtype Meta as M + +instance + _ : N.DataSegment Context + _ = record { get = id ; set = (\_ c -> c) } + _ : M.DataSegment Context + _ = record { get = (\m -> Meta.context m) ; + set = (\m c -> record m {context = c}) } + _ : M.DataSegment Meta + _ = record { get = id ; set = (\_ m -> m) } + + +liftContext : {X Y : Set} {{_ : N.DataSegment X}} {{_ : N.DataSegment Y}} -> N.CodeSegment X Y -> N.CodeSegment Context Context +liftContext {{x}} {{y}} (N.cs f) = N.cs (\c -> N.DataSegment.set y c (f (N.DataSegment.get x c))) + +liftMeta : {X Y : Set} {{_ : M.DataSegment X}} {{_ : M.DataSegment Y}} -> N.CodeSegment X Y -> M.CodeSegment X Y +liftMeta (N.cs f) = M.cs f + + +gotoMeta : {I O : Set} {{_ : N.DataSegment I}} {{_ : N.DataSegment O}} -> M.CodeSegment Meta Meta -> N.CodeSegment I O -> Meta -> Meta +gotoMeta mCode code m = M.exec mCode (record m {next = (liftContext code)}) + +push : M.CodeSegment Meta Meta +push = M.cs (\m -> M.exec (liftMeta (Meta.next m)) (record m {c' = Context.c (Meta.context m)})) + + +record ds0 : Set where + field + a : Int + b : Int + +record ds1 : Set where + field + c : Int + +instance + _ : N.DataSegment ds0 + _ = record { set = (\c d -> record c {a = (ds0.a d) ; b = (ds0.b d)}) + ; get = (\c -> record { a = (Context.a c) ; b = (Context.b c)})} + _ : N.DataSegment ds1 + _ = record { set = (\c d -> record c {c = (ds1.c d)}) + ; get = (\c -> record { c = (Context.c c)})} + +cs2 : N.CodeSegment ds1 ds1 +cs2 = N.cs id + +cs1 : N.CodeSegment ds1 ds1 +cs1 = N.cs (\d -> N.goto cs2 d) + +cs0 : N.CodeSegment ds0 ds1 +cs0 = N.cs (\d -> N.goto cs1 (record {c = (ds0.a d) + (ds0.b d)})) + + +main : Meta +main = gotoMeta push cs0 (record {context = (record {a = 100 ; b = 50 ; c = 70}) ; c' = 0 ; next = (N.cs id)}) +-- record {context = record {a = 100 ; b = 50 ; c = 150} ; c' = 70 ; next = (N.cs id)}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/atton-master-meta-sample.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,77 @@ +module atton-master-meta-sample where + +open import Data.Nat +open import Data.Unit +open import Function +Int = @$\mathbb{N}$@ + +record Context : Set where + field + a : Int + b : Int + c : Int + +open import subtype Context as N + +record Meta : Set where + field + context : Context + c' : Int + next : N.CodeSegment Context Context + +open import subtype Meta as M + +instance + _ : N.DataSegment Context + _ = record { get = id ; set = (\_ c @$\rightarrow$@ c) } + _ : M.DataSegment Context + _ = record { get = (\m @$\rightarrow$@ Meta.context m) ; + set = (\m c @$\rightarrow$@ record m {context = c}) } + _ : M.DataSegment Meta + _ = record { get = id ; set = (\_ m @$\rightarrow$@ m) } + + +liftContext : {X Y : Set} {{_ : N.DataSegment X}} {{_ : N.DataSegment Y}} @$\rightarrow$@ N.CodeSegment X Y @$\rightarrow$@ N.CodeSegment Context Context +liftContext {{x}} {{y}} (N.cs f) = N.cs (\c @$\rightarrow$@ N.DataSegment.set y c (f (N.DataSegment.get x c))) + +liftMeta : {X Y : Set} {{_ : M.DataSegment X}} {{_ : M.DataSegment Y}} @$\rightarrow$@ N.CodeSegment X Y @$\rightarrow$@ M.CodeSegment X Y +liftMeta (N.cs f) = M.cs f + + +gotoMeta : {I O : Set} {{_ : N.DataSegment I}} {{_ : N.DataSegment O}} @$\rightarrow$@ M.CodeSegment Meta Meta @$\rightarrow$@ N.CodeSegment I O @$\rightarrow$@ Meta @$\rightarrow$@ Meta +gotoMeta mCode code m = M.exec mCode (record m {next = (liftContext code)}) + +push : M.CodeSegment Meta Meta +push = M.cs (\m @$\rightarrow$@ M.exec (liftMeta (Meta.next m)) (record m {c' = Context.c (Meta.context m)})) + + +record ds0 : Set where + field + a : Int + b : Int + +record ds1 : Set where + field + c : Int + +instance + _ : N.DataSegment ds0 + _ = record { set = (\c d @$\rightarrow$@ record c {a = (ds0.a d) ; b = (ds0.b d)}) + ; get = (\c @$\rightarrow$@ record { a = (Context.a c) ; b = (Context.b c)})} + _ : N.DataSegment ds1 + _ = record { set = (\c d @$\rightarrow$@ record c {c = (ds1.c d)}) + ; get = (\c @$\rightarrow$@ record { c = (Context.c c)})} + +cs2 : N.CodeSegment ds1 ds1 +cs2 = N.cs id + +cs1 : N.CodeSegment ds1 ds1 +cs1 = N.cs (\d @$\rightarrow$@ N.goto cs2 d) + +cs0 : N.CodeSegment ds0 ds1 +cs0 = N.cs (\d @$\rightarrow$@ N.goto cs1 (record {c = (ds0.a d) + (ds0.b d)})) + + +main : Meta +main = gotoMeta push cs0 (record {context = (record {a = 100 ; b = 50 ; c = 70}) ; c' = 0 ; next = (N.cs id)}) +-- record {context = record {a = 100 ; b = 50 ; c = 150} ; c' = 70 ; next = (N.cs id)}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/atton-master-sample.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,46 @@ +module atton-master-sample where + +open import Data.Nat +open import Data.Unit +open import Function +Int = ℕ + +record Context : Set where + field + a : Int + b : Int + c : Int + + +open import subtype Context + + + +record ds0 : Set where + field + a : Int + b : Int + +record ds1 : Set where + field + c : Int + +instance + _ : DataSegment ds0 + _ = record { set = (\c d -> record c {a = (ds0.a d) ; b = (ds0.b d)}) + ; get = (\c -> record { a = (Context.a c) ; b = (Context.b c)})} + _ : DataSegment ds1 + _ = record { set = (\c d -> record c {c = (ds1.c d)}) + ; get = (\c -> record { c = (Context.c c)})} + +cs2 : CodeSegment ds1 ds1 +cs2 = cs id + +cs1 : CodeSegment ds1 ds1 +cs1 = cs (\d -> goto cs2 d) + +cs0 : CodeSegment ds0 ds1 +cs0 = cs (\d -> goto cs1 (record {c = (ds0.a d) + (ds0.b d)})) + +main : ds1 +main = goto cs0 (record {a = 100 ; b = 50})
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/atton-master-sample.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,46 @@ +module atton-master-sample where + +open import Data.Nat +open import Data.Unit +open import Function +Int = @$\mathbb{N}$@ + +record Context : Set where + field + a : Int + b : Int + c : Int + + +open import subtype Context + + + +record ds0 : Set where + field + a : Int + b : Int + +record ds1 : Set where + field + c : Int + +instance + _ : DataSegment ds0 + _ = record { set = (\c d @$\rightarrow$@ record c {a = (ds0.a d) ; b = (ds0.b d)}) + ; get = (\c @$\rightarrow$@ record { a = (Context.a c) ; b = (Context.b c)})} + _ : DataSegment ds1 + _ = record { set = (\c d @$\rightarrow$@ record c {c = (ds1.c d)}) + ; get = (\c @$\rightarrow$@ record { c = (Context.c c)})} + +cs2 : CodeSegment ds1 ds1 +cs2 = cs id + +cs1 : CodeSegment ds1 ds1 +cs1 = cs (\d @$\rightarrow$@ goto cs2 d) + +cs0 : CodeSegment ds0 ds1 +cs0 = cs (\d @$\rightarrow$@ goto cs1 (record {c = (ds0.a d) + (ds0.b d)})) + +main : ds1 +main = goto cs0 (record {a = 100 ; b = 50})
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/axiom-taut.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +_⇒_ : Bool → Bool → Bool +false ⇒ _ = true +true ⇒ true = true +true ⇒ false = false + +Axiom : Cond -> PrimComm -> Cond -> Set +Axiom pre comm post = ∀ (env : Env) → (pre env) ⇒ ( post (comm env)) ≡ true + +Tautology : Cond -> Cond -> Set +Tautology pre post = ∀ (env : Env) → (pre env) ⇒ (post env) ≡ true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/axiom-taut.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +_@$\Rightarrow$@_ : Bool @$\rightarrow$@ Bool @$\rightarrow$@ Bool +false @$\Rightarrow$@ _ = true +true @$\Rightarrow$@ true = true +true @$\Rightarrow$@ false = false + +Axiom : Cond @$\rightarrow$@ PrimComm @$\rightarrow$@ Cond @$\rightarrow$@ Set +Axiom pre comm post = @$\forall$@ (env : Env) @$\rightarrow$@ (pre env) @$\Rightarrow$@ ( post (comm env)) @$\equiv$@ true + +Tautology : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Set +Tautology pre post = @$\forall$@ (env : Env) @$\rightarrow$@ (pre env) @$\Rightarrow$@ (post env) @$\equiv$@ true
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-agda.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +plus : {l : Level} {t : Set l} → (x y : ℕ) → (next : ℕ -> t) -> t +plus x zero next = next x +plus x (suc y) next = plus (suc x) y next + +-- plus 10 20 +-- λ next → next 30
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-agda.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +plus : {l : Level} {t : Set l} @$\rightarrow$@ (x y : @$\mathbb{N}$@) @$\rightarrow$@ (next : @$\mathbb{N}$@ @$\rightarrow$@ t) @$\rightarrow$@ t +plus x zero next = next x +plus x (suc y) next = plus (suc x) y next + +-- plus 10 20 +-- @$\lambda$@ next @$\rightarrow$@ next 30
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-condition.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +data whileTestState : Set where + s1 : whileTestState + s2 : whileTestState + sf : whileTestState + +whileTestStateP : whileTestState → Envc → Set +whileTestStateP s1 env = (vari env ≡ 0) /\ (varn env ≡ c10 env) +whileTestStateP s2 env = (varn env + vari env ≡ c10 env) +whileTestStateP sf env = (vari env ≡ c10 env)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-condition.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +data whileTestState : Set where + s1 : whileTestState + s2 : whileTestState + sf : whileTestState + +whileTestStateP : whileTestState @$\rightarrow$@ Envc @$\rightarrow$@ Set +whileTestStateP s1 env = (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) +whileTestStateP s2 env = (varn env + vari env @$\equiv$@ c10 env) +whileTestStateP sf env = (vari env @$\equiv$@ c10 env)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-helperCall.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +whileCallwP : (c : ℕ) → whileTestPCallwP' c +whileCallwP c = whileTestPwP {_} {_} c + (λ env s → loopHelper c (record { c10 = c ; varn = c ; vari = zero }) refl +zero)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-helperCall.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +whileCallwP : (c : @$\mathbb{N}$@) @$\rightarrow$@ whileTestPCallwP' c +whileCallwP c = whileTestPwP {_} {_} c + (@$\lambda$@ env s @$\rightarrow$@ loopHelper c (record { c10 = c ; varn = c ; vari = zero }) refl +zero)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-loop.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +whileLoopPwP' : {l : Level} {t : Set l} → (n : ℕ) → (env : Envc ) + → (n ≡ varn env) → whileTestStateP s2 env + → (next : (env : Envc ) → (pred n ≡ varn env) → whileTestStateP s2 env → t) + → (exit : (env : Envc ) → whileTestStateP sf env → t) → t +whileLoopPwP' zero env refl refl _ exit = exit env refl +whileLoopPwP' (suc n) env refl refl next _ = + next (record env {varn = pred (varn env) ; vari = suc (vari env) }) refl (+-suc n (vari env)) + + +loopPwP' : {l : Level} {t : Set l} → (n : ℕ) → (env : Envc ) + → (n ≡ varn env) → whileTestStateP s2 env + → (exit : (env : Envc ) → whileTestStateP sf env → t) → t +loopPwP' zero env refl refl exit = exit env refl +loopPwP' (suc n) env refl refl exit + = whileLoopPwP' (suc n) env refl refl (λ env x y → loopPwP' n env x y exit) exit
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-loop.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +whileLoopPwP' : {l : Level} {t : Set l} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc ) + @$\rightarrow$@ (n @$\equiv$@ varn env) @$\rightarrow$@ whileTestStateP s2 env + @$\rightarrow$@ (next : (env : Envc ) @$\rightarrow$@ (pred n @$\equiv$@ varn env) @$\rightarrow$@ whileTestStateP s2 env @$\rightarrow$@ t) + @$\rightarrow$@ (exit : (env : Envc ) @$\rightarrow$@ whileTestStateP sf env @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopPwP' zero env refl refl _ exit = exit env refl +whileLoopPwP' (suc n) env refl refl next _ = + next (record env {varn = pred (varn env) ; vari = suc (vari env) }) refl (+-suc n (vari env)) + + +loopPwP' : {l : Level} {t : Set l} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc ) + @$\rightarrow$@ (n @$\equiv$@ varn env) @$\rightarrow$@ whileTestStateP s2 env + @$\rightarrow$@ (exit : (env : Envc ) @$\rightarrow$@ whileTestStateP sf env @$\rightarrow$@ t) @$\rightarrow$@ t +loopPwP' zero env refl refl exit = exit env refl +loopPwP' (suc n) env refl refl exit + = whileLoopPwP' (suc n) env refl refl (@$\lambda$@ env x y @$\rightarrow$@ loopPwP' n env x y exit) exit
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-loophelper.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +loopHelper : (n : ℕ) → (env : Envc ) → (eq : varn env ≡ n) → (seq : whileTestStateP s2 env) + → loopPwP' n env (sym eq) seq (λ env₁ x → (vari env₁ ≡ c10 env₁)) +loopHelper zero env eq refl rewrite eq = refl +loopHelper (suc n) env refl refl = + loopHelper n (record { c10 = suc (n + vari env) ; varn = n ; vari = suc (vari env) }) refl (+-suc n (vari env))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-loophelper.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +loopHelper : (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc ) @$\rightarrow$@ (eq : varn env @$\equiv$@ n) @$\rightarrow$@ (seq : whileTestStateP s2 env) + @$\rightarrow$@ loopPwP' n env (sym eq) seq (@$\lambda$@ env@$\_{1}$@ x @$\rightarrow$@ (vari env@$\_{1}$@ @$\equiv$@ c10 env@$\_{1}$@)) +loopHelper zero env eq refl rewrite eq = refl +loopHelper (suc n) env refl refl = + loopHelper n (record { c10 = suc (n + vari env) ; varn = n ; vari = suc (vari env) }) refl (+-suc n (vari env))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-prim.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +whileTestPwP : {l : Level} {t : Set l} → (c10 : ℕ) → ((env : Envc ) → whileTestStateP s1 env → t) → t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( λ env → env )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-prim.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +whileTestPwP : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ ((env : Envc ) @$\rightarrow$@ whileTestStateP s1 env @$\rightarrow$@ t) @$\rightarrow$@ t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( @$\lambda$@ env @$\rightarrow$@ env )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-soundness.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +whileCallwP : (c : ℕ) → whileTestPCallwP' c +whileCallwP c = whileTestPwP {_} {_} c + (λ env s → loopPwP' (c10 env) env (sym (pi2 s)) (conv env s) {!!}) + where + conv : (env : Envc ) → (vari env ≡ 0) /\ (varn env ≡ c10 env) → varn env + vari env ≡ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-soundness.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +whileCallwP : (c : @$\mathbb{N}$@) @$\rightarrow$@ whileTestPCallwP' c +whileCallwP c = whileTestPwP {_} {_} c + (@$\lambda$@ env s @$\rightarrow$@ loopPwP' (c10 env) env (sym (pi2 s)) (conv env s) {!!}) + where + conv : (env : Envc ) @$\rightarrow$@ (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) @$\rightarrow$@ varn env + vari env @$\equiv$@ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-while.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +whileCallwP : (c : ℕ ) → Set +whileCallwP c = whileTestPwP {_} {_} c (λ env s → loopPwP' (varn env) env refl (conv env s) ( λ env s → vari env ≡ c10 env ) ) + where + conv : (env : Envc ) → (vari env ≡ 0) /\ (varn env ≡ c10 env) → varn env + vari env ≡ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare-while.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +whileCallwP : (c : @$\mathbb{N}$@ ) @$\rightarrow$@ Set +whileCallwP c = whileTestPwP {_} {_} c (@$\lambda$@ env s @$\rightarrow$@ loopPwP' (varn env) env refl (conv env s) ( @$\lambda$@ env s @$\rightarrow$@ vari env @$\equiv$@ c10 env ) ) + where + conv : (env : Envc ) @$\rightarrow$@ (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) @$\rightarrow$@ varn env + vari env @$\equiv$@ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,14 @@ +whileTestPwP : {l : Level} {t : Set l} → (c10 : ℕ) → ((env : Envc ) → whileTestStateP s1 env → t) → t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( λ env → env ) + +loopPwP' : {l : Level} {t : Set l} → (n : ℕ) → (env : Envc ) → (n ≡ varn env) → whileTestStateP s2 env → (exit : (env : Envc ) → whileTestStateP sf env → t) → t +loopPwP' zero env refl refl exit = exit env refl +loopPwP' (suc n) env refl refl exit = whileLoopPwP' (suc n) env refl refl (λ env x y → loopPwP' n env x y exit) exit + + +whileTestPCallwP' : (c : ℕ ) → Set +whileTestPCallwP' c = whileTestPwP {_} {_} c (λ env s → loopPwP' (varn env) env refl (conv env s) ( λ env s → vari env ≡ c10 env ) ) + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc-hoare.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,14 @@ +whileTestPwP : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ ((env : Envc ) @$\rightarrow$@ whileTestStateP s1 env @$\rightarrow$@ t) @$\rightarrow$@ t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( @$\lambda$@ env @$\rightarrow$@ env ) + +loopPwP' : {l : Level} {t : Set l} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc ) @$\rightarrow$@ (n @$\equiv$@ varn env) @$\rightarrow$@ whileTestStateP s2 env @$\rightarrow$@ (exit : (env : Envc ) @$\rightarrow$@ whileTestStateP sf env @$\rightarrow$@ t) @$\rightarrow$@ t +loopPwP' zero env refl refl exit = exit env refl +loopPwP' (suc n) env refl refl exit = whileLoopPwP' (suc n) env refl refl (@$\lambda$@ env x y @$\rightarrow$@ loopPwP' n env x y exit) exit + + +whileTestPCallwP' : (c : @$\mathbb{N}$@ ) @$\rightarrow$@ Set +whileTestPCallwP' c = whileTestPwP {_} {_} c (@$\lambda$@ env s @$\rightarrow$@ loopPwP' (varn env) env refl (conv env s) ( @$\lambda$@ env s @$\rightarrow$@ vari env @$\equiv$@ c10 env ) ) + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc/fib.c Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,20 @@ +#include<stdio.h> +#include<stdlib.h> + + +void fin(unsigned long long n){ + printf("%lld", n); + exit(0); +} + +void fib(unsigned long long n, unsigned long long a, unsigned long long b){ + if (n==0) fin(a); + if (n==1) fin(b); + fib(n-2, a+b, a+b+b); +} + +int main(int argc, char *argv[]){ + unsigned long long n=atoll(argv[1]); + fib(n,0,1); +} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cbc/fib.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,19 @@ +#include<stdio.h> +#include<stdlib.h> + + +__code fin(unsigned long long n){ + printf("%lld", n); +} + +__code fib(unsigned long long n, unsigned long long a, unsigned long long b){ + if (n==0) goto fin(a); + if (n==1) goto fin(b); + goto fib(n-2, a+b, a+b+b); +} + +int main(int argc, char *argv[]){ + unsigned long long n = atoll(argv[1]); + goto fib(n,0,1); +} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cg1.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +__code cg0(int a, int b) { + goto cg1(a+b); +} + +__code cg1(int c) { + goto cg2(c); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/codeGearExample.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +__code add(struct Integer* input1, struct Integer* input2, __code next(struct Integer* output, ...)) { + output->value = input1->value + input2->value; + goto next(output, ...); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/contextContinuation.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,14 @@ +// normal level Code Gear +__code cg0(struct Context* context, struct Integer integer, struct Queue queue) { + ... +} + +// meta level stub Code Gear +__code cg0_stub(struct Context* context) { + // get data index number + Integer integer = &context->data[context->dataNum]->Integer + // get enum data + Queue* queue = &context->data[Queue]->Queue; + // continuation Code Gear + goto cg0(context, integer, queue); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/createCPUWorker.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,21 @@ +Worker* createCPUWorker(struct Context* context, int id, Queue* queue) { + struct Worker* worker = new Worker(); + struct CPUWorker* cpuWorker = new CPUWorker(); + worker->worker = (union Data*)cpuWorker; + worker->tasks = queue; + cpuWorker->id = id; + cpuWorker->loopCounter = 0; + worker->taskReceive = C_taskReceiveCPUWorker; + worker->shutdown = C_shutdownCPUWorker; + pthread_create(&worker->thread, NULL, (void*)&startWorker, worker); + return worker; +} + +static void startWorker(struct Worker* worker) { + struct CPUWorker* cpuWorker = &worker->worker->CPUWorker; + cpuWorker->context = NEW(struct Context); + initContext(cpuWorker->context); + Gearef(cpuWorker->context, Worker)->worker = (union Data*)worker; + Gearef(cpuWorker->context, Worker)->tasks = worker->tasks; + goto meta(cpuWorker->context, worker->taskReceive); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/createTaskManager.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,46 @@ +TaskManager* createTaskManagerImpl(struct Context* context, int numCPU, int numGPU, int numIO) { + struct TaskManager* taskManager = new TaskManager(); + taskManager->spawnTasks = C_spawnTasksTaskManagerImpl; + taskManager->spawn = C_spawnTaskManagerImpl; + taskManager->shutdown = C_shutdownTaskManagerImpl; + taskManager->incrementTaskCount = C_incrementTaskCountTaskManagerImpl; + taskManager->decrementTaskCount = C_decrementTaskCountTaskManagerImpl; + taskManager->setWaitTask = C_setWaitTaskTaskManagerImpl; + struct TaskManagerImpl* taskManagerImpl = new TaskManagerImpl(); + // 0...numIO-1 IOProcessor + // numIO...numIO+numGPU-1 GPUProcessor + // numIO+numGPU...numIO+numGPU+numCPU-1 CPUProcessor + taskManagerImpl->io = 0; + taskManagerImpl->gpu = numIO; + taskManagerImpl->cpu = numIO+numGPU; + taskManagerImpl->maxCPU = numIO+numGPU+numCPU; + taskManagerImpl->numWorker = taskManagerImpl->maxCPU; + taskManagerImpl->sendGPUWorkerIndex = taskManagerImpl->gpu; + taskManagerImpl->sendCPUWorkerIndex = taskManagerImpl->cpu; + taskManagerImpl->taskCount = 0; + taskManagerImpl->loopCounter = 0; + createWorkers(context, taskManagerImpl); + taskManager->taskManager = (union Data*)taskManagerImpl; + return taskManager; +} + +void createWorkers(struct Context* context, TaskManagerImpl* taskManager) { + int i = 0; + taskManager->workers = (Worker**)ALLOCATE_PTR_ARRAY(context, Worker, taskManager->maxCPU); + for (;i<taskManager->gpu;i++) { + Queue* queue = createSynchronizedQueue(context); + taskManager->workers[i] = (Worker*)createCPUWorker(context, i, queue); + } + for (;i<taskManager->cpu;i++) { + Queue* queue = createSynchronizedQueue(context); +#ifdef USE_CUDAWorker + taskManager->workers[i] = (Worker*)createCUDAWorker(context, i, queue,0); +#else + taskManager->workers[i] = (Worker*)createCPUWorker(context, i, queue); +#endif + } + for (;i<taskManager->maxCPU;i++) { + Queue* queue = createSynchronizedQueue(context); + taskManager->workers[i] = (Worker*)createCPUWorker(context, i, queue); + } +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/cuLaunchKernel.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,21 @@ +int computeblockDim(int count, int maxThreadPerBlock) { + return count < maxThreadPerBlock ? count : maxThreadPerBlock; +} + +__code execCUDAExecutor(struct CUDAExecutor* executor, struct Context* task, __code next(...)) { + // check data parallelism task + if (task->iterate) { + struct MultiDimIterator* iterator = &task->iterator->iterator->MultiDimIterator; + + // compute block thread size + int blockDimX = computeblockDim(iterator->x, executor->maxThreadPerBlock); + int blockDimY = computeblockDim(iterator->y, executor->maxThreadPerBlock); + int blockDimZ = computeblockDim(iterator->z, executor->maxThreadPerBlock); + + checkCudaErrors(cuLaunchKernel(task->function, + iterator->x/blockDimX, iterator->y/blockDimY, iterator->z/blockDimZ, + blockDimX, blockDimY, blockDimZ, + 0, NULL, (void**)executor->kernelParams, NULL)); + } + ... +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/env.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +record Envc : Set where + field + vari : ℕ + varn : ℕ + c10 : ℕ + +makeEnv : ℕ → ℕ → ℕ → Envc +makeEnv i n c = record { vari = i ; varn = n ; c10 = c }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/env.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,8 @@ +record Envc : Set where + field + vari : @$\mathbb{N}$@ + varn : @$\mathbb{N}$@ + c10 : @$\mathbb{N}$@ + +makeEnv : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ Envc +makeEnv i n c = record { vari = i ; varn = n ; c10 = c }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/ex_stack.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +__code clearSingleLinkedStack(struct SingleLinkedStack* stack,__code next(...)) { + stack->top = NULL; + goto next(...); +} + +__code pushSingleLinkedStack(struct SingleLinkedStack* stack,union Data* data, __code next(...)) { + Element* element = new Element(); + element->next = stack->top; + element->data = data; + stack->top = element; + goto next(...); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/excbc.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +__code cs0(int a, int b) { + goto cs1(a+b); +} + +__code cs1(int c) { + goto cs2(c); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/factrial.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,29 @@ +__code print_factorial(int prod) +{ + printf("factorial = %d\n", prod); + exit(0); +} + +__code factorial0(int prod, int x) +{ + if (x >= 1) { + goto factorial0(prod*x, x-1); + } else { + goto print_factorial(prod); + } + +} + +__code factorial(int x) +{ + goto factorial0(1, x); +} + +int main(int argc, char **argv) +{ + int i; + i = atoi(argv[1]); + + goto factorial(i); +} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/function.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +_-_ :ℕ →ℕ →ℕ +x - zero = x +zero - _ = zero +(suc x) - (suc y) = x - y
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/function.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +_-_ :@$\mathbb{N}$@ @$\rightarrow$@@$\mathbb{N}$@ @$\rightarrow$@@$\mathbb{N}$@ +x - zero = x +zero - _ = zero +(suc x) - (suc y) = x - y
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/gears-while.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,51 @@ +whileTest : {l : Level} {t : Set l} -> {c10 : ℕ } → (Code : (env : Env) -> + ((vari env) ≡ 0) /\ ((varn env) ≡ c10) -> t) -> t +whileTest {_} {_} {c10} next = next env proof2 + where + env : Env + env = record {vari = 0 ; varn = c10} + proof2 : ((vari env) ≡ 0) /\ ((varn env) ≡ c10) + proof2 = record {pi1 = refl ; pi2 = refl} + +conversion1 : {l : Level} {t : Set l } → (env : Env) -> {c10 : ℕ } → ((vari env) ≡ 0) /\ ((varn env) ≡ c10) + -> (Code : (env1 : Env) -> (varn env1 + vari env1 ≡ c10) -> t) -> t +conversion1 env {c10} p1 next = next env proof4 + where + proof4 : varn env + vari env ≡ c10 + proof4 = let open ≡-Reasoning in + begin + varn env + vari env + ≡⟨ cong ( λ n → n + vari env ) (pi2 p1 ) ⟩ + c10 + vari env + ≡⟨ cong ( λ n → c10 + n ) (pi1 p1 ) ⟩ + c10 + 0 + ≡⟨ +-sym {c10} {0} ⟩ + c10 + ∎ + +{-# TERMINATING #-} +whileLoop : {l : Level} {t : Set l} -> (env : Env) -> {c10 : ℕ } → ((varn env) + (vari env) ≡ c10) -> (Code : Env -> t) -> t +whileLoop env proof next with ( suc zero ≤? (varn env) ) +whileLoop env proof next | no p = next env +whileLoop env {c10} proof next | yes p = whileLoop env1 (proof3 p ) next + where + env1 = record {varn = (varn env) - 1 ; vari = (vari env) + 1} + 1<0 : 1 ≤ zero → ⊥ + 1<0 () + proof3 : (suc zero ≤ (varn env)) → varn env1 + vari env1 ≡ c10 + proof3 (s≤s lt) with varn env + proof3 (s≤s z≤n) | zero = ⊥-elim (1<0 p) + proof3 (s≤s (z≤n {n'}) ) | suc n = let open ≡-Reasoning in + begin + n' + (vari env + 1) + ≡⟨ cong ( λ z → n' + z ) ( +-sym {vari env} {1} ) ⟩ + n' + (1 + vari env ) + ≡⟨ sym ( +-assoc (n') 1 (vari env) ) ⟩ + (n' + 1) + vari env + ≡⟨ cong ( λ z → z + vari env ) +1≡suc ⟩ + (suc n' ) + vari env + ≡⟨⟩ + varn env + vari env + ≡⟨ proof ⟩ + c10 + ∎
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/gears-while.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,51 @@ +whileTest : {l : Level} {t : Set l} @$\rightarrow$@ {c10 : @$\mathbb{N}$@ } @$\rightarrow$@ (Code : (env : Env) @$\rightarrow$@ + ((vari env) @$\equiv$@ 0) @$\wedge$@ ((varn env) @$\equiv$@ c10) @$\rightarrow$@ t) @$\rightarrow$@ t +whileTest {_} {_} {c10} next = next env proof2 + where + env : Env + env = record {vari = 0 ; varn = c10} + proof2 : ((vari env) @$\equiv$@ 0) @$\wedge$@ ((varn env) @$\equiv$@ c10) + proof2 = record {pi1 = refl ; pi2 = refl} + +conversion1 : {l : Level} {t : Set l } @$\rightarrow$@ (env : Env) @$\rightarrow$@ {c10 : @$\mathbb{N}$@ } @$\rightarrow$@ ((vari env) @$\equiv$@ 0) @$\wedge$@ ((varn env) @$\equiv$@ c10) + @$\rightarrow$@ (Code : (env1 : Env) @$\rightarrow$@ (varn env1 + vari env1 @$\equiv$@ c10) @$\rightarrow$@ t) @$\rightarrow$@ t +conversion1 env {c10} p1 next = next env proof4 + where + proof4 : varn env + vari env @$\equiv$@ c10 + proof4 = let open @$\equiv$@-Reasoning in + begin + varn env + vari env + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ n @$\rightarrow$@ n + vari env ) (pi2 p1 ) @$\rangle$@ + c10 + vari env + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ n @$\rightarrow$@ c10 + n ) (pi1 p1 ) @$\rangle$@ + c10 + 0 + @$\equiv$@@$\langle$@ +-sym {c10} {0} @$\rangle$@ + c10 + @$\blacksquare$@ + +{-@$\#$@ TERMINATING @$\#$@-} +whileLoop : {l : Level} {t : Set l} @$\rightarrow$@ (env : Env) @$\rightarrow$@ {c10 : @$\mathbb{N}$@ } @$\rightarrow$@ ((varn env) + (vari env) @$\equiv$@ c10) @$\rightarrow$@ (Code : Env @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoop env proof next with ( suc zero @$\leq$@? (varn env) ) +whileLoop env proof next | no p = next env +whileLoop env {c10} proof next | yes p = whileLoop env1 (proof3 p ) next + where + env1 = record {varn = (varn env) - 1 ; vari = (vari env) + 1} + 1<0 : 1 @$\leq$@ zero @$\rightarrow$@ @$\bot$@ + 1<0 () + proof3 : (suc zero @$\leq$@ (varn env)) @$\rightarrow$@ varn env1 + vari env1 @$\equiv$@ c10 + proof3 (s@$\leq$@s lt) with varn env + proof3 (s@$\leq$@s z@$\leq$@n) | zero = @$\bot$@-elim (1<0 p) + proof3 (s@$\leq$@s (z@$\leq$@n {n'}) ) | suc n = let open @$\equiv$@-Reasoning in + begin + n' + (vari env + 1) + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ n' + z ) ( +-sym {vari env} {1} ) @$\rangle$@ + n' + (1 + vari env ) + @$\equiv$@@$\langle$@ sym ( +-assoc (n') 1 (vari env) ) @$\rangle$@ + (n' + 1) + vari env + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ z + vari env ) +1@$\equiv$@suc @$\rangle$@ + (suc n' ) + vari env + @$\equiv$@@$\langle$@@$\rangle$@ + varn env + vari env + @$\equiv$@@$\langle$@ proof @$\rangle$@ + c10 + @$\blacksquare$@
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/gears.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +proofGears : {c10 : ℕ } → Set +proofGears {c10} = whileTest {_} {_} {c10} (λ n p1 → conversion1 n p1 (λ n1 p2 → whileLoop' n1 p2 (λ n2 → ( vari n2 ≡ c10 ))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/gears.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +proofGears : {c10 : @$\mathbb{N}$@ } @$\rightarrow$@ Set +proofGears {c10} = whileTest {_} {_} {c10} (@$\lambda$@ n p1 @$\rightarrow$@ conversion1 n p1 (@$\lambda$@ n1 p2 @$\rightarrow$@ whileLoop' n1 p2 (@$\lambda$@ n2 @$\rightarrow$@ ( vari n2 @$\equiv$@ c10 ))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/goto.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +__code cs0(int a, int b){ + goto cs1(a+b); +} + +__code cs1(int c){ + goto cs2(c); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/implies.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +data _implies_ (A B : Set ) : Set (succ Zero) where + proof : ( A → B ) → A implies B
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/implies.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +data _implies_ (A B : Set ) : Set (succ Zero) where + proof : ( A @$\rightarrow$@ B ) @$\rightarrow$@ A implies B
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/interface.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +typedef struct Stack<Type, Impl>{ + union Data* stack; + union Data* data; + union Data* data1; + + __code whenEmpty(...); + __code clear(Impl* stack,__code next(...)); + __code push(Impl* stack,Type* data, __code next(...)); + __code pop(Impl* stack, __code next(Type* data, ...)); + __code get(Impl* stack, __code next(Type* data, ...)); + __code next(...); +} Stack;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/iterateCall.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,96 @@ +#include "../context.h" +#interface "Iterator.h" +#interface "TaskManager.h" +#include <stdio.h> + +Iterator* createMultiDimIterator(struct Context* context, int x, int y, int z) { + struct Iterator* iterator = new Iterator(); + struct MultiDimIterator* multiDimIterator = new MultiDimIterator(); + iterator->iterator = (union Data*)multiDimIterator; + iterator->exec = C_execMultiDimIterator; + iterator->barrier = C_barrierMultiDimIterator; + multiDimIterator->x = x; + multiDimIterator->y = y; + multiDimIterator->z = z; + multiDimIterator->count = x * y * z; + multiDimIterator->counterX = 0; + multiDimIterator->counterY = 0; + multiDimIterator->counterZ = 0; + return iterator; +} + +/** + * create iterateTask with index, that copy from task argument + * @return created iterateTask + * @param task task of the copy source + * @x index + */ +struct Context* createMultiDimIterateTask(struct Context* task, int x, int y, int z) { + struct Context* task1 = NEW(struct Context); + initContext(task1); + task1->taskManager = task->taskManager; + task1->next = task->next; + task1->iterate = 1; + task1->iterator = task->iterator; + task1->idgCount = task->idgCount; + task1->idg = task->idg; + task1->maxIdg = task->maxIdg; + for(int i = task1->idg; i < task1->maxIdg; i++) { + task1->data[i] = task->data[i]; + } + + // create index data gear and register input data to iterate task + struct MultiDim* multiDim = &ALLOCATE_DATA_GEAR(task1, MultiDim)->MultiDim; + multiDim->x = x; + multiDim->y = y; + multiDim->z = z; + task1->data[task1->maxIdg++] = (union Data*)multiDim; + task1->odg = task->odg + 1; + task1->maxOdg = task->maxOdg + 1; + for (int i = task1->odg; i < task1->maxOdg; i++) { + task1->data[i] = task->data[i-1]; + } + + return task1; +} + +__code execMultiDimIterator(struct MultiDimIterator* iterator, struct Context* task, int numGPU, __code next(...)) { + // No GPU device + if (numGPU == 0) { + goto execMultiDimIterator1(); + } + task->iterate = 1; + task->gpu = 1; + struct TaskManager* taskManager = task->taskManager; + goto taskManager->spawn(task, next(...)); +} + +__code execMultiDimIterator1(struct MultiDimIterator* iterator, struct Context* task, __code next(...)) { + int x = iterator->counterX; + int y = iterator->counterY; + int z = iterator->counterZ; + struct Context* iterateTask = createMultiDimIterateTask(task, x, y, z); + struct TaskManager* taskManager = task->taskManager; + goto taskManager->spawn(iterateTask, execMultiDimIterator2); +} + +__code execMultiDimIterator2(struct MultiDimIterator* iterator, struct Context* task, __code next(...)) { + if (++iterator->counterX >= iterator->x) { + iterator->counterX = 0; + if (++iterator->counterY >= iterator->y) { + iterator->counterY = 0; + if (++iterator->counterZ >= iterator->z) { + iterator->counterZ = 0; + goto next(...); + } + } + } + goto execMultiDimIterator1(); +} + +__code barrierMultiDimIterator(struct MultiDimIterator* iterator, struct Context* task, __code next(...), __code whenWait(...)) { + if (task->gpu || __sync_fetch_and_sub(&iterator->count, 1) == 1) { + goto next(...); + } + goto whenWait(...); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/iteratePargoto.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +__code code1() { + par goto printIterator(input, output, iterate(2), __exit); + goto code2(); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/metaCodeGearExample.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,13 @@ +__code add_stub(struct Context* context) { + // Input Data Gear + Integer* input1 = &context->data[context->idg + 0]->Integer; + Integer* input2 = &context->data[context->idg + 1]->Integer; + + // set Continuation + enum Code next = context->next; + + // Output Data Gear + Integer** O_output = (Integer **)&context->data[context->odg + 0]; + goto add(context, input1, input2, next, O_output); +} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/metaCreateTask.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,42 @@ +__code code1(struct Context *context, Integer *integer1, Integer *integer2, Integer *output) { + // create context + context->task = NEW(struct Context); + initContext(context->task); + + // set task parameter + context->task->next = C_add; + context->task->idgCount = 2; + context->task->idg = context->task->dataNum; + context->task->maxIdg = context->task->idg + 2; + context->task->odg = context->task->maxIdg; + context->task->maxOdg = context->task->odg + 1; + + // create Data Gear Queue + GET_META(integer1)->wait = createSynchronizedQueue(context); + GET_META(integer2)->wait = createSynchronizedQueue(context); + GET_META(integer3)->wait = createSynchronizedQueue(context); + + // set Input Data Gear + context->task->data[context->task->idg+0] = (union Data*)integer1; + context->task->data[context->task->idg+1] = (union Data*)integer2; + + // set Output Data Gear + context->task->data[context->task->odg+0] = (union Data*)integer3; + + // add taskList Element + struct Element* element; + element = &ALLOCATE(context, Element)->Element; + element->data = (union Data*)context->task; + element->next = context->taskList; + context->taskList = element; + + // set TaskManager->spawns parameter + Gearef(context, TaskManager)->taskList = context->taskList; + Gearef(context, TaskManager)->next1 = C_code2; + goto meta(context, C_code2); +} + +// code gear +__code add(Integer *integer1, Integer *integer2, next(Integer *output, ...)) { + .... +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/parGotoCreateTask.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +__code code1(Integer *integer1, Integer * integer2, Integer *output) { + par goto add(integer1, integer2, output, __exit); + goto code2(); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/putSynchronizedQueue.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,17 @@ +__code putSynchronizedQueue(struct SynchronizedQueue* queue, union Data* data, __code next(...)) { + Element* element = new Element(); + element->data = data; + element->next = NULL; + Element* last = queue->last; + Element* nextElement = last->next; + if (last != queue->last) { + goto putSynchronizedQueue(); + } + if (nextElement == NULL) { + struct Atomic* atomic = queue->atomic; + goto atomic->checkAndSet(&last->next, nextElement, element, next(...), putSynchronizedQueue); + } else { // wrong last element + struct Atomic* atomic = queue->atomic; + goto atomic->checkAndSet(&queue->last, last, nextElement, putSynchronizedQueue, putSynchronizedQueue); + } +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/record.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +record Env : Set where + field + varn : ℕ + vari : ℕ
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/record.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +record Env : Set where + field + varn : @$\mathbb{N}$@ + vari : @$\mathbb{N}$@
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/redBlackTreeTest.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,196 @@ +module redBlackTreeTest where + +open import RedBlackTree +open import stack +open import Level hiding (zero) + +open import Data.Nat + +open Tree +open Node +open RedBlackTree.RedBlackTree +open Stack + +-- tests + +putTree1 : {n m : Level } {a k : Set n} {t : Set m} -> RedBlackTree {n} {m} {t} a k -> k -> a -> (RedBlackTree {n} {m} {t} a k -> t) -> t +putTree1 {n} {m} {a} {k} {t} tree k1 value next with (root tree) +... | Nothing = next (record tree {root = Just (leafNode k1 value) }) +... | Just n2 = clearSingleLinkedStack (nodeStack tree) (\ s -> findNode tree s (leafNode k1 value) n2 (\ tree1 s n1 -> replaceNode tree1 s n1 next)) + +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Function + + +check1 : {m : Level } (n : Maybe (Node ℕ ℕ)) -> ℕ -> Bool {m} +check1 Nothing _ = False +check1 (Just n) x with Data.Nat.compare (value n) x +... | equal _ = True +... | _ = False + +check2 : {m : Level } (n : Maybe (Node ℕ ℕ)) -> ℕ -> Bool {m} +check2 Nothing _ = False +check2 (Just n) x with compare2 (value n) x +... | EQ = True +... | _ = False + +test1 : putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ {Set Level.zero} ) 1 1 ( \t -> getRedBlackTree t 1 ( \t x -> check2 x 1 ≡ True )) +test1 = refl + +test2 : putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ {Set Level.zero} ) 1 1 ( + \t -> putTree1 t 2 2 ( + \t -> getRedBlackTree t 1 ( + \t x -> check2 x 1 ≡ True ))) +test2 = refl + +open ≡-Reasoning +test3 : putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ {Set Level.zero}) 1 1 + $ \t -> putTree1 t 2 2 + $ \t -> putTree1 t 3 3 + $ \t -> putTree1 t 4 4 + $ \t -> getRedBlackTree t 1 + $ \t x -> check2 x 1 ≡ True +test3 = begin + check2 (Just (record {key = 1 ; value = 1 ; color = Black ; left = Nothing ; right = Just (leafNode 2 2)})) 1 + ≡⟨ refl ⟩ + True + ∎ + +test31 = putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ ) 1 1 + $ \t -> putTree1 t 2 2 + $ \t -> putTree1 t 3 3 + $ \t -> putTree1 t 4 4 + $ \t -> getRedBlackTree t 4 + $ \t x -> x + +-- test5 : Maybe (Node ℕ ℕ) +test5 = putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ ) 4 4 + $ \t -> putTree1 t 6 6 + $ \t0 -> clearSingleLinkedStack (nodeStack t0) + $ \s -> findNode1 t0 s (leafNode 3 3) ( root t0 ) + $ \t1 s n1 -> replaceNode t1 s n1 + $ \t -> getRedBlackTree t 3 + -- $ \t x -> SingleLinkedStack.top (stack s) + -- $ \t x -> n1 + $ \t x -> root t + where + findNode1 : {n m : Level } {a k : Set n} {t : Set m} -> RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> (Node a k) -> (Maybe (Node a k)) -> (RedBlackTree {n} {m} {t} a k -> SingleLinkedStack (Node a k) -> Node a k -> t) -> t + findNode1 t s n1 Nothing next = next t s n1 + findNode1 t s n1 ( Just n2 ) next = findNode t s n1 n2 next + +-- test51 : putTree1 {_} {_} {ℕ} {ℕ} {_} {Maybe (Node ℕ ℕ)} (createEmptyRedBlackTreeℕ ℕ {Set Level.zero} ) 1 1 $ \t -> +-- putTree1 t 2 2 $ \t -> putTree1 t 3 3 $ \t -> root t ≡ Just (record { key = 1; value = 1; left = Just (record { key = 2 ; value = 2 } ); right = Nothing} ) +-- test51 = refl + +test6 : Maybe (Node ℕ ℕ) +test6 = root (createEmptyRedBlackTreeℕ {_} ℕ {Maybe (Node ℕ ℕ)}) + + +test7 : Maybe (Node ℕ ℕ) +test7 = clearSingleLinkedStack (nodeStack tree2) (\ s -> replaceNode tree2 s n2 (\ t -> root t)) + where + tree2 = createEmptyRedBlackTreeℕ {_} ℕ {Maybe (Node ℕ ℕ)} + k1 = 1 + n2 = leafNode 0 0 + value1 = 1 + +test8 : Maybe (Node ℕ ℕ) +test8 = putTree1 {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ) 1 1 + $ \t -> putTree1 t 2 2 (\ t -> root t) + + +test9 : putRedBlackTree {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ {Set Level.zero} ) 1 1 ( \t -> getRedBlackTree t 1 ( \t x -> check2 x 1 ≡ True )) +test9 = refl + +test10 : putRedBlackTree {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ {Set Level.zero} ) 1 1 ( + \t -> putRedBlackTree t 2 2 ( + \t -> getRedBlackTree t 1 ( + \t x -> check2 x 1 ≡ True ))) +test10 = refl + +test11 = putRedBlackTree {_} {_} {ℕ} {ℕ} (createEmptyRedBlackTreeℕ ℕ) 1 1 + $ \t -> putRedBlackTree t 2 2 + $ \t -> putRedBlackTree t 3 3 + $ \t -> getRedBlackTree t 2 + $ \t x -> root t + + +redBlackInSomeState : { m : Level } (a : Set Level.zero) (n : Maybe (Node a ℕ)) {t : Set m} -> RedBlackTree {Level.zero} {m} {t} a ℕ +redBlackInSomeState {m} a n {t} = record { root = n ; nodeStack = emptySingleLinkedStack ; compare = compare2 } + +-- compare2 : (x y : ℕ ) -> compareresult +-- compare2 zero zero = eq +-- compare2 (suc _) zero = gt +-- compare2 zero (suc _) = lt +-- compare2 (suc x) (suc y) = compare2 x y + +putTest1Lemma2 : (k : ℕ) -> compare2 k k ≡ EQ +putTest1Lemma2 zero = refl +putTest1Lemma2 (suc k) = putTest1Lemma2 k + +putTest1Lemma1 : (x y : ℕ) -> compareℕ x y ≡ compare2 x y +putTest1Lemma1 zero zero = refl +putTest1Lemma1 (suc m) zero = refl +putTest1Lemma1 zero (suc n) = refl +putTest1Lemma1 (suc m) (suc n) with Data.Nat.compare m n +putTest1Lemma1 (suc .m) (suc .(Data.Nat.suc m + k)) | less m k = lemma1 m + where + lemma1 : (m : ℕ) -> LT ≡ compare2 m (ℕ.suc (m + k)) + lemma1 zero = refl + lemma1 (suc y) = lemma1 y +putTest1Lemma1 (suc .m) (suc .m) | equal m = lemma1 m + where + lemma1 : (m : ℕ) -> EQ ≡ compare2 m m + lemma1 zero = refl + lemma1 (suc y) = lemma1 y +putTest1Lemma1 (suc .(Data.Nat.suc m + k)) (suc .m) | greater m k = lemma1 m + where + lemma1 : (m : ℕ) -> GT ≡ compare2 (ℕ.suc (m + k)) m + lemma1 zero = refl + lemma1 (suc y) = lemma1 y + +putTest1Lemma3 : (k : ℕ) -> compareℕ k k ≡ EQ +putTest1Lemma3 k = trans (putTest1Lemma1 k k) ( putTest1Lemma2 k ) + +compareLemma1 : {x y : ℕ} -> compare2 x y ≡ EQ -> x ≡ y +compareLemma1 {zero} {zero} refl = refl +compareLemma1 {zero} {suc _} () +compareLemma1 {suc _} {zero} () +compareLemma1 {suc x} {suc y} eq = cong ( \z -> ℕ.suc z ) ( compareLemma1 ( trans lemma2 eq ) ) + where + lemma2 : compare2 (ℕ.suc x) (ℕ.suc y) ≡ compare2 x y + lemma2 = refl + + +putTest1 :{ m : Level } (n : Maybe (Node ℕ ℕ)) + -> (k : ℕ) (x : ℕ) + -> putTree1 {_} {_} {ℕ} {ℕ} (redBlackInSomeState {_} ℕ n {Set Level.zero}) k x + (\ t -> getRedBlackTree t k (\ t x1 -> check2 x1 x ≡ True)) +putTest1 n k x with n +... | Just n1 = lemma2 ( record { top = Nothing } ) + where + lemma2 : (s : SingleLinkedStack (Node ℕ ℕ) ) -> putTree1 (record { root = Just n1 ; nodeStack = s ; compare = compare2 }) k x (λ t → + GetRedBlackTree.checkNode t k (λ t₁ x1 → check2 x1 x ≡ True) (root t)) + lemma2 s with compare2 k (key n1) + ... | EQ = lemma3 {!!} + where + lemma3 : compare2 k (key n1) ≡ EQ -> getRedBlackTree {_} {_} {ℕ} {ℕ} {Set Level.zero} ( record { root = Just ( record { + key = key n1 ; value = x ; right = right n1 ; left = left n1 ; color = Black + } ) ; nodeStack = s ; compare = λ x₁ y → compare2 x₁ y } ) k ( \ t x1 -> check2 x1 x ≡ True) + lemma3 eq with compare2 x x | putTest1Lemma2 x + ... | EQ | refl with compare2 k (key n1) | eq + ... | EQ | refl with compare2 x x | putTest1Lemma2 x + ... | EQ | refl = refl + ... | GT = {!!} + ... | LT = {!!} + +... | Nothing = lemma1 + where + lemma1 : getRedBlackTree {_} {_} {ℕ} {ℕ} {Set Level.zero} ( record { root = Just ( record { + key = k ; value = x ; right = Nothing ; left = Nothing ; color = Red + } ) ; nodeStack = record { top = Nothing } ; compare = λ x₁ y → compare2 x₁ y } ) k + ( \ t x1 -> check2 x1 x ≡ True) + lemma1 with compare2 k k | putTest1Lemma2 k + ... | EQ | refl with compare2 x x | putTest1Lemma2 x + ... | EQ | refl = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/redBlackTreeTest.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,196 @@ +module redBlackTreeTest where + +open import RedBlackTree +open import stack +open import Level hiding (zero) + +open import Data.Nat + +open Tree +open Node +open RedBlackTree.RedBlackTree +open Stack + +-- tests + +putTree1 : {n m : Level } {a k : Set n} {t : Set m} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ k @$\rightarrow$@ a @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ t) @$\rightarrow$@ t +putTree1 {n} {m} {a} {k} {t} tree k1 value next with (root tree) +... | Nothing = next (record tree {root = Just (leafNode k1 value) }) +... | Just n2 = clearSingleLinkedStack (nodeStack tree) (\ s @$\rightarrow$@ findNode tree s (leafNode k1 value) n2 (\ tree1 s n1 @$\rightarrow$@ replaceNode tree1 s n1 next)) + +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Function + + +check1 : {m : Level } (n : Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@)) @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ Bool {m} +check1 Nothing _ = False +check1 (Just n) x with Data.Nat.compare (value n) x +... | equal _ = True +... | _ = False + +check2 : {m : Level } (n : Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@)) @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ Bool {m} +check2 Nothing _ = False +check2 (Just n) x with compare2 (value n) x +... | EQ = True +... | _ = False + +test1 : putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ {Set Level.zero} ) 1 1 ( \t @$\rightarrow$@ getRedBlackTree t 1 ( \t x @$\rightarrow$@ check2 x 1 @$\equiv$@ True )) +test1 = refl + +test2 : putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ {Set Level.zero} ) 1 1 ( + \t @$\rightarrow$@ putTree1 t 2 2 ( + \t @$\rightarrow$@ getRedBlackTree t 1 ( + \t x @$\rightarrow$@ check2 x 1 @$\equiv$@ True ))) +test2 = refl + +open @$\equiv$@-Reasoning +test3 : putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ {Set Level.zero}) 1 1 + $ \t @$\rightarrow$@ putTree1 t 2 2 + $ \t @$\rightarrow$@ putTree1 t 3 3 + $ \t @$\rightarrow$@ putTree1 t 4 4 + $ \t @$\rightarrow$@ getRedBlackTree t 1 + $ \t x @$\rightarrow$@ check2 x 1 @$\equiv$@ True +test3 = begin + check2 (Just (record {key = 1 ; value = 1 ; color = Black ; left = Nothing ; right = Just (leafNode 2 2)})) 1 + @$\equiv$@@$\langle$@ refl @$\rangle$@ + True + @$\blacksquare$@ + +test31 = putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ ) 1 1 + $ \t @$\rightarrow$@ putTree1 t 2 2 + $ \t @$\rightarrow$@ putTree1 t 3 3 + $ \t @$\rightarrow$@ putTree1 t 4 4 + $ \t @$\rightarrow$@ getRedBlackTree t 4 + $ \t x @$\rightarrow$@ x + +-- test5 : Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@) +test5 = putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ ) 4 4 + $ \t @$\rightarrow$@ putTree1 t 6 6 + $ \t0 @$\rightarrow$@ clearSingleLinkedStack (nodeStack t0) + $ \s @$\rightarrow$@ findNode1 t0 s (leafNode 3 3) ( root t0 ) + $ \t1 s n1 @$\rightarrow$@ replaceNode t1 s n1 + $ \t @$\rightarrow$@ getRedBlackTree t 3 + -- $ \t x @$\rightarrow$@ SingleLinkedStack.top (stack s) + -- $ \t x @$\rightarrow$@ n1 + $ \t x @$\rightarrow$@ root t + where + findNode1 : {n m : Level } {a k : Set n} {t : Set m} @$\rightarrow$@ RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ (Node a k) @$\rightarrow$@ (Maybe (Node a k)) @$\rightarrow$@ (RedBlackTree {n} {m} {t} a k @$\rightarrow$@ SingleLinkedStack (Node a k) @$\rightarrow$@ Node a k @$\rightarrow$@ t) @$\rightarrow$@ t + findNode1 t s n1 Nothing next = next t s n1 + findNode1 t s n1 ( Just n2 ) next = findNode t s n1 n2 next + +-- test51 : putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} {_} {Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@)} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ {Set Level.zero} ) 1 1 $ \t @$\rightarrow$@ +-- putTree1 t 2 2 $ \t @$\rightarrow$@ putTree1 t 3 3 $ \t @$\rightarrow$@ root t @$\equiv$@ Just (record { key = 1; value = 1; left = Just (record { key = 2 ; value = 2 } ); right = Nothing} ) +-- test51 = refl + +test6 : Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@) +test6 = root (createEmptyRedBlackTree@$\mathbb{N}$@ {_} @$\mathbb{N}$@ {Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@)}) + + +test7 : Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@) +test7 = clearSingleLinkedStack (nodeStack tree2) (\ s @$\rightarrow$@ replaceNode tree2 s n2 (\ t @$\rightarrow$@ root t)) + where + tree2 = createEmptyRedBlackTree@$\mathbb{N}$@ {_} @$\mathbb{N}$@ {Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@)} + k1 = 1 + n2 = leafNode 0 0 + value1 = 1 + +test8 : Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@) +test8 = putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@) 1 1 + $ \t @$\rightarrow$@ putTree1 t 2 2 (\ t @$\rightarrow$@ root t) + + +test9 : putRedBlackTree {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ {Set Level.zero} ) 1 1 ( \t @$\rightarrow$@ getRedBlackTree t 1 ( \t x @$\rightarrow$@ check2 x 1 @$\equiv$@ True )) +test9 = refl + +test10 : putRedBlackTree {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@ {Set Level.zero} ) 1 1 ( + \t @$\rightarrow$@ putRedBlackTree t 2 2 ( + \t @$\rightarrow$@ getRedBlackTree t 1 ( + \t x @$\rightarrow$@ check2 x 1 @$\equiv$@ True ))) +test10 = refl + +test11 = putRedBlackTree {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (createEmptyRedBlackTree@$\mathbb{N}$@ @$\mathbb{N}$@) 1 1 + $ \t @$\rightarrow$@ putRedBlackTree t 2 2 + $ \t @$\rightarrow$@ putRedBlackTree t 3 3 + $ \t @$\rightarrow$@ getRedBlackTree t 2 + $ \t x @$\rightarrow$@ root t + + +redBlackInSomeState : { m : Level } (a : Set Level.zero) (n : Maybe (Node a @$\mathbb{N}$@)) {t : Set m} @$\rightarrow$@ RedBlackTree {Level.zero} {m} {t} a @$\mathbb{N}$@ +redBlackInSomeState {m} a n {t} = record { root = n ; nodeStack = emptySingleLinkedStack ; compare = compare2 } + +-- compare2 : (x y : @$\mathbb{N}$@ ) @$\rightarrow$@ compareresult +-- compare2 zero zero = eq +-- compare2 (suc _) zero = gt +-- compare2 zero (suc _) = lt +-- compare2 (suc x) (suc y) = compare2 x y + +putTest1Lemma2 : (k : @$\mathbb{N}$@) @$\rightarrow$@ compare2 k k @$\equiv$@ EQ +putTest1Lemma2 zero = refl +putTest1Lemma2 (suc k) = putTest1Lemma2 k + +putTest1Lemma1 : (x y : @$\mathbb{N}$@) @$\rightarrow$@ compare@$\mathbb{N}$@ x y @$\equiv$@ compare2 x y +putTest1Lemma1 zero zero = refl +putTest1Lemma1 (suc m) zero = refl +putTest1Lemma1 zero (suc n) = refl +putTest1Lemma1 (suc m) (suc n) with Data.Nat.compare m n +putTest1Lemma1 (suc .m) (suc .(Data.Nat.suc m + k)) | less m k = lemma1 m + where + lemma1 : (m : @$\mathbb{N}$@) @$\rightarrow$@ LT @$\equiv$@ compare2 m (@$\mathbb{N}$@.suc (m + k)) + lemma1 zero = refl + lemma1 (suc y) = lemma1 y +putTest1Lemma1 (suc .m) (suc .m) | equal m = lemma1 m + where + lemma1 : (m : @$\mathbb{N}$@) @$\rightarrow$@ EQ @$\equiv$@ compare2 m m + lemma1 zero = refl + lemma1 (suc y) = lemma1 y +putTest1Lemma1 (suc .(Data.Nat.suc m + k)) (suc .m) | greater m k = lemma1 m + where + lemma1 : (m : @$\mathbb{N}$@) @$\rightarrow$@ GT @$\equiv$@ compare2 (@$\mathbb{N}$@.suc (m + k)) m + lemma1 zero = refl + lemma1 (suc y) = lemma1 y + +putTest1Lemma3 : (k : @$\mathbb{N}$@) @$\rightarrow$@ compare@$\mathbb{N}$@ k k @$\equiv$@ EQ +putTest1Lemma3 k = trans (putTest1Lemma1 k k) ( putTest1Lemma2 k ) + +compareLemma1 : {x y : @$\mathbb{N}$@} @$\rightarrow$@ compare2 x y @$\equiv$@ EQ @$\rightarrow$@ x @$\equiv$@ y +compareLemma1 {zero} {zero} refl = refl +compareLemma1 {zero} {suc _} () +compareLemma1 {suc _} {zero} () +compareLemma1 {suc x} {suc y} eq = cong ( \z @$\rightarrow$@ @$\mathbb{N}$@.suc z ) ( compareLemma1 ( trans lemma2 eq ) ) + where + lemma2 : compare2 (@$\mathbb{N}$@.suc x) (@$\mathbb{N}$@.suc y) @$\equiv$@ compare2 x y + lemma2 = refl + + +putTest1 :{ m : Level } (n : Maybe (Node @$\mathbb{N}$@ @$\mathbb{N}$@)) + @$\rightarrow$@ (k : @$\mathbb{N}$@) (x : @$\mathbb{N}$@) + @$\rightarrow$@ putTree1 {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} (redBlackInSomeState {_} @$\mathbb{N}$@ n {Set Level.zero}) k x + (\ t @$\rightarrow$@ getRedBlackTree t k (\ t x1 @$\rightarrow$@ check2 x1 x @$\equiv$@ True)) +putTest1 n k x with n +... | Just n1 = lemma2 ( record { top = Nothing } ) + where + lemma2 : (s : SingleLinkedStack (Node @$\mathbb{N}$@ @$\mathbb{N}$@) ) @$\rightarrow$@ putTree1 (record { root = Just n1 ; nodeStack = s ; compare = compare2 }) k x (@$\lambda$@ t @$\rightarrow$@ + GetRedBlackTree.checkNode t k (@$\lambda$@ t@$\_{1}$@ x1 @$\rightarrow$@ check2 x1 x @$\equiv$@ True) (root t)) + lemma2 s with compare2 k (key n1) + ... | EQ = lemma3 {!!} + where + lemma3 : compare2 k (key n1) @$\equiv$@ EQ @$\rightarrow$@ getRedBlackTree {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} {Set Level.zero} ( record { root = Just ( record { + key = key n1 ; value = x ; right = right n1 ; left = left n1 ; color = Black + } ) ; nodeStack = s ; compare = @$\lambda$@ x@$\_{1}$@ y @$\rightarrow$@ compare2 x@$\_{1}$@ y } ) k ( \ t x1 @$\rightarrow$@ check2 x1 x @$\equiv$@ True) + lemma3 eq with compare2 x x | putTest1Lemma2 x + ... | EQ | refl with compare2 k (key n1) | eq + ... | EQ | refl with compare2 x x | putTest1Lemma2 x + ... | EQ | refl = refl + ... | GT = {!!} + ... | LT = {!!} + +... | Nothing = lemma1 + where + lemma1 : getRedBlackTree {_} {_} {@$\mathbb{N}$@} {@$\mathbb{N}$@} {Set Level.zero} ( record { root = Just ( record { + key = k ; value = x ; right = Nothing ; left = Nothing ; color = Red + } ) ; nodeStack = record { top = Nothing } ; compare = @$\lambda$@ x@$\_{1}$@ y @$\rightarrow$@ compare2 x@$\_{1}$@ y } ) k + ( \ t x1 @$\rightarrow$@ check2 x1 x @$\equiv$@ True) + lemma1 with compare2 k k | putTest1Lemma2 k + ... | EQ | refl with compare2 x x | putTest1Lemma2 x + ... | EQ | refl = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/sendTask.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,32 @@ +__code spawnTaskManagerImpl(struct TaskManagerImpl* taskManager, struct Context* task, __code next(...)) { + if (task->idgCount == 0) { + goto taskSend(); + } + goto next(...); +} + +__code taskSend(struct TaskManagerImpl* taskManager, struct Context* task, __code next(...)) { + if (task->gpu) { + goto taskSend1(); + } else { + goto taskSend2(); + } +} + +__code taskSend1(struct TaskManagerImpl* taskManager, struct Context* task, __code next(...)) { + int workerId = taskManager->sendGPUWorkerIndex; + if(++taskManager->sendGPUWorkerIndex >= taskManager->cpu) { + taskManager->sendGPUWorkerIndex = taskManager->gpu; + } + struct Queue* queue = taskManager->workers[workerId]->tasks; + goto queue->put(task, next(...)); +} + +__code taskSend2(struct TaskManagerImpl* taskManager, struct Context* task, __code next(...)) { + int workerId = taskManager->sendCPUWorkerIndex; + if(++taskManager->sendCPUWorkerIndex >= taskManager->maxCPU) { + taskManager->sendCPUWorkerIndex = taskManager->cpu; + } + struct Queue* queue = taskManager->workers[workerId]->tasks; + goto queue->put(task, next(...)); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/singleLinkedQueue.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,30 @@ +#interface "Queue.h" + +Queue* createSingleLinkedQueue(struct Context* context) { + struct Queue* queue = new Queue(); // Allocate Queue interface + struct SingleLinkedQueue* singleLinkedQueue = new SingleLinkedQueue(); // Allocate Queue implement + queue->queue = (union Data*)singleLinkedQueue; + singleLinkedQueue->top = new Element(); + singleLinkedQueue->last = singleLinkedQueue->top; + queue->clear = C_clearSingleLinkedQueue; + queue->put = C_putSingleLinkedQueue; + queue->take = C_takeSingleLinkedQueue; + queue->isEmpty = C_isEmptySingleLinkedQueue; + return queue; +} + +__code clearSingleLinkedQueue(struct SingleLinkedQueue* queue, __code next(...)) { + queue->top = NULL; + goto next(...); +} + +__code putSingleLinkedQueue(struct SingleLinkedQueue* queue, union Data* data, __code next(...)) { + Element* element = new Element(); + element->data = data; + element->next = NULL; + queue->last->next = element; + queue->last = element; + goto next(...); +} + +.....
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/singleLinkedQueueTest.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ +__code code1() { + Queue* queue = createSingleLinkedQueue(context); + Node* node = new Node(); + node->color = Red; + goto queue->put(node, queueTest2); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/singleLinkedQueueTest_script.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +__code code1(struct Context *context) { + Queue* queue = createSingleLinkedQueue(context); + Node* node = &ALLOCATE(context, Node)->Node; + node->color = Red; + Gearef(context, Queue)->queue = (union Data*) queue; + Gearef(context, Queue)->data = (union Data*) node; + Gearef(context, Queue)->next = C_queueTest2; + goto meta(context, queue->put); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/singleLinkedStackInterface.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,12 @@ +Stack* createSingleLinkedStack(struct Context* context) { + struct Stack* stack = new Stack(); + struct SingleLinkedStack* singleLinkedStack = new SingleLinkedStack(); + stack->stack = (union Data*)singleLinkedStack; + singleLinkedStack->top = NULL; + stack->push = C_pushSingleLinkedStack; + stack->pop = C_popSingleLinkedStack; + stack->get = C_getSingleLinkedStack; + stack->isEmpty = C_isEmptySingleLinkedStack; + stack->clear = C_clearSingleLinkedStack; + return stack; +} \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stack-product.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,158 @@ +module stack-product where + +open import product +open import Data.Product +open import Data.Nat +open import Function using (id) +open import Relation.Binary.PropositionalEquality + +-- definition based from Gears(209:5708390a9d88) src/parallel_execution +goto = executeCS + +data Bool : Set where + True : Bool + False : Bool + +data Maybe (a : Set) : Set where + Nothing : Maybe a + Just : a -> Maybe a + + +record Stack {a t : Set} (stackImpl : Set) : Set where + field + stack : stackImpl + push : CodeSegment (stackImpl × a × (CodeSegment stackImpl t)) t + pop : CodeSegment (stackImpl × (CodeSegment (stackImpl × Maybe a) t)) t + + +data Element (a : Set) : Set where + cons : a -> Maybe (Element a) -> Element a + +datum : {a : Set} -> Element a -> a +datum (cons a _) = a + +next : {a : Set} -> Element a -> Maybe (Element a) +next (cons _ n) = n + +record SingleLinkedStack (a : Set) : Set where + field + top : Maybe (Element a) +open SingleLinkedStack + +emptySingleLinkedStack : {a : Set} -> SingleLinkedStack a +emptySingleLinkedStack = record {top = Nothing} + + + + +pushSingleLinkedStack : {a t : Set} -> CodeSegment ((SingleLinkedStack a) × a × (CodeSegment (SingleLinkedStack a) t)) t +pushSingleLinkedStack = cs push + where + push : {a t : Set} -> ((SingleLinkedStack a) × a × (CodeSegment (SingleLinkedStack a) t)) -> t + push (stack , datum , next) = goto next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + +popSingleLinkedStack : {a t : Set} -> CodeSegment (SingleLinkedStack a × (CodeSegment (SingleLinkedStack a × Maybe a) t)) t +popSingleLinkedStack = cs pop + where + pop : {a t : Set} -> (SingleLinkedStack a × (CodeSegment (SingleLinkedStack a × Maybe a) t)) -> t + pop (record { top = Nothing } , nextCS) = goto nextCS (emptySingleLinkedStack , Nothing) + pop (record { top = Just x } , nextCS) = goto nextCS (stack1 , (Just datum1)) + where + datum1 = datum x + stack1 = record { top = (next x) } + + + + + +createSingleLinkedStack : {a b : Set} -> Stack {a} {b} (SingleLinkedStack a) +createSingleLinkedStack = record { stack = emptySingleLinkedStack + ; push = pushSingleLinkedStack + ; pop = popSingleLinkedStack + } + + + + +test01 : {a : Set} -> CodeSegment (SingleLinkedStack a × Maybe a) Bool +test01 = cs test01' + where + test01' : {a : Set} -> (SingleLinkedStack a × Maybe a) -> Bool + test01' (record { top = Nothing } , _) = False + test01' (record { top = Just x } , _) = True + + +test02 : {a : Set} -> CodeSegment (SingleLinkedStack a) (SingleLinkedStack a × Maybe a) +test02 = cs test02' + where + test02' : {a : Set} -> SingleLinkedStack a -> (SingleLinkedStack a × Maybe a) + test02' stack = goto popSingleLinkedStack (stack , (cs id)) + + +test03 : {a : Set} -> CodeSegment a (SingleLinkedStack a) +test03 = cs test03' + where + test03' : {a : Set} -> a -> SingleLinkedStack a + test03' a = goto pushSingleLinkedStack (emptySingleLinkedStack , a , (cs id)) + + +lemma : {A : Set} {a : A} -> goto (test03 ◎ test02 ◎ test01) a ≡ False +lemma = refl + + +n-push : {A : Set} {a : A} -> CodeSegment (ℕ × SingleLinkedStack A) (ℕ × SingleLinkedStack A) +n-push {A} {a} = cs (push {A} {a}) + where + push : {A : Set} {a : A} -> (ℕ × SingleLinkedStack A) -> (ℕ × SingleLinkedStack A) + push {A} {a} (zero , s) = (zero , s) + push {A} {a} (suc n , s) = goto pushSingleLinkedStack (s , a , {!!} {- n-push -}) -- needs subtype + + +{- + +n-push : {A : Set} {a : A} -> Nat -> SingleLinkedStack A -> SingleLinkedStack A +n-push zero s = s +n-push {A} {a} (suc n) s = pushSingleLinkedStack (n-push {A} {a} n s) a (\s -> s) + +n-pop : {A : Set} {a : A} -> Nat -> SingleLinkedStack A -> SingleLinkedStack A +n-pop zero s = s +n-pop {A} {a} (suc n) s = popSingleLinkedStack (n-pop {A} {a} n s) (\s _ -> s) + +open ≡-Reasoning + +push-pop-equiv : {A : Set} {a : A} (s : SingleLinkedStack A) -> popSingleLinkedStack (pushSingleLinkedStack s a (\s -> s)) (\s _ -> s) ≡ s +push-pop-equiv s = refl + +push-and-n-pop : {A : Set} {a : A} (n : Nat) (s : SingleLinkedStack A) -> n-pop {A} {a} (suc n) (pushSingleLinkedStack s a id) ≡ n-pop {A} {a} n s +push-and-n-pop zero s = refl +push-and-n-pop {A} {a} (suc n) s = begin + n-pop (suc (suc n)) (pushSingleLinkedStack s a id) + ≡⟨ refl ⟩ + popSingleLinkedStack (n-pop (suc n) (pushSingleLinkedStack s a id)) (\s _ -> s) + ≡⟨ cong (\s -> popSingleLinkedStack s (\s _ -> s)) (push-and-n-pop n s) ⟩ + popSingleLinkedStack (n-pop n s) (\s _ -> s) + ≡⟨ refl ⟩ + n-pop (suc n) s + ∎ + + +n-push-pop-equiv : {A : Set} {a : A} (n : Nat) (s : SingleLinkedStack A) -> (n-pop {A} {a} n (n-push {A} {a} n s)) ≡ s +n-push-pop-equiv zero s = refl +n-push-pop-equiv {A} {a} (suc n) s = begin + n-pop (suc n) (n-push (suc n) s) + ≡⟨ refl ⟩ + n-pop (suc n) (pushSingleLinkedStack (n-push n s) a (\s -> s)) + ≡⟨ push-and-n-pop n (n-push n s) ⟩ + n-pop n (n-push n s) + ≡⟨ n-push-pop-equiv n s ⟩ + s + ∎ + + +n-push-pop-equiv-empty : {A : Set} {a : A} -> (n : Nat) -> n-pop {A} {a} n (n-push {A} {a} n emptySingleLinkedStack) ≡ emptySingleLinkedStack +n-push-pop-equiv-empty n = n-push-pop-equiv n emptySingleLinkedStack +-} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stack-product.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,158 @@ +module stack-product where + +open import product +open import Data.Product +open import Data.Nat +open import Function using (id) +open import Relation.Binary.PropositionalEquality + +-- definition based from Gears(209:5708390a9d88) src/parallel_execution +goto = executeCS + +data Bool : Set where + True : Bool + False : Bool + +data Maybe (a : Set) : Set where + Nothing : Maybe a + Just : a @$\rightarrow$@ Maybe a + + +record Stack {a t : Set} (stackImpl : Set) : Set where + field + stack : stackImpl + push : CodeSegment (stackImpl @$\times$@ a @$\times$@ (CodeSegment stackImpl t)) t + pop : CodeSegment (stackImpl @$\times$@ (CodeSegment (stackImpl @$\times$@ Maybe a) t)) t + + +data Element (a : Set) : Set where + cons : a @$\rightarrow$@ Maybe (Element a) @$\rightarrow$@ Element a + +datum : {a : Set} @$\rightarrow$@ Element a @$\rightarrow$@ a +datum (cons a _) = a + +next : {a : Set} @$\rightarrow$@ Element a @$\rightarrow$@ Maybe (Element a) +next (cons _ n) = n + +record SingleLinkedStack (a : Set) : Set where + field + top : Maybe (Element a) +open SingleLinkedStack + +emptySingleLinkedStack : {a : Set} @$\rightarrow$@ SingleLinkedStack a +emptySingleLinkedStack = record {top = Nothing} + + + + +pushSingleLinkedStack : {a t : Set} @$\rightarrow$@ CodeSegment ((SingleLinkedStack a) @$\times$@ a @$\times$@ (CodeSegment (SingleLinkedStack a) t)) t +pushSingleLinkedStack = cs push + where + push : {a t : Set} @$\rightarrow$@ ((SingleLinkedStack a) @$\times$@ a @$\times$@ (CodeSegment (SingleLinkedStack a) t)) @$\rightarrow$@ t + push (stack , datum , next) = goto next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + +popSingleLinkedStack : {a t : Set} @$\rightarrow$@ CodeSegment (SingleLinkedStack a @$\times$@ (CodeSegment (SingleLinkedStack a @$\times$@ Maybe a) t)) t +popSingleLinkedStack = cs pop + where + pop : {a t : Set} @$\rightarrow$@ (SingleLinkedStack a @$\times$@ (CodeSegment (SingleLinkedStack a @$\times$@ Maybe a) t)) @$\rightarrow$@ t + pop (record { top = Nothing } , nextCS) = goto nextCS (emptySingleLinkedStack , Nothing) + pop (record { top = Just x } , nextCS) = goto nextCS (stack1 , (Just datum1)) + where + datum1 = datum x + stack1 = record { top = (next x) } + + + + + +createSingleLinkedStack : {a b : Set} @$\rightarrow$@ Stack {a} {b} (SingleLinkedStack a) +createSingleLinkedStack = record { stack = emptySingleLinkedStack + ; push = pushSingleLinkedStack + ; pop = popSingleLinkedStack + } + + + + +test01 : {a : Set} @$\rightarrow$@ CodeSegment (SingleLinkedStack a @$\times$@ Maybe a) Bool +test01 = cs test01' + where + test01' : {a : Set} @$\rightarrow$@ (SingleLinkedStack a @$\times$@ Maybe a) @$\rightarrow$@ Bool + test01' (record { top = Nothing } , _) = False + test01' (record { top = Just x } , _) = True + + +test02 : {a : Set} @$\rightarrow$@ CodeSegment (SingleLinkedStack a) (SingleLinkedStack a @$\times$@ Maybe a) +test02 = cs test02' + where + test02' : {a : Set} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (SingleLinkedStack a @$\times$@ Maybe a) + test02' stack = goto popSingleLinkedStack (stack , (cs id)) + + +test03 : {a : Set} @$\rightarrow$@ CodeSegment a (SingleLinkedStack a) +test03 = cs test03' + where + test03' : {a : Set} @$\rightarrow$@ a @$\rightarrow$@ SingleLinkedStack a + test03' a = goto pushSingleLinkedStack (emptySingleLinkedStack , a , (cs id)) + + +lemma : {A : Set} {a : A} @$\rightarrow$@ goto (test03 ◎ test02 ◎ test01) a @$\equiv$@ False +lemma = refl + + +n-push : {A : Set} {a : A} @$\rightarrow$@ CodeSegment (@$\mathbb{N}$@ @$\times$@ SingleLinkedStack A) (@$\mathbb{N}$@ @$\times$@ SingleLinkedStack A) +n-push {A} {a} = cs (push {A} {a}) + where + push : {A : Set} {a : A} @$\rightarrow$@ (@$\mathbb{N}$@ @$\times$@ SingleLinkedStack A) @$\rightarrow$@ (@$\mathbb{N}$@ @$\times$@ SingleLinkedStack A) + push {A} {a} (zero , s) = (zero , s) + push {A} {a} (suc n , s) = goto pushSingleLinkedStack (s , a , {!!} {- n-push -}) -- needs subtype + + +{- + +n-push : {A : Set} {a : A} @$\rightarrow$@ Nat @$\rightarrow$@ SingleLinkedStack A @$\rightarrow$@ SingleLinkedStack A +n-push zero s = s +n-push {A} {a} (suc n) s = pushSingleLinkedStack (n-push {A} {a} n s) a (\s @$\rightarrow$@ s) + +n-pop : {A : Set} {a : A} @$\rightarrow$@ Nat @$\rightarrow$@ SingleLinkedStack A @$\rightarrow$@ SingleLinkedStack A +n-pop zero s = s +n-pop {A} {a} (suc n) s = popSingleLinkedStack (n-pop {A} {a} n s) (\s _ @$\rightarrow$@ s) + +open @$\equiv$@-Reasoning + +push-pop-equiv : {A : Set} {a : A} (s : SingleLinkedStack A) @$\rightarrow$@ popSingleLinkedStack (pushSingleLinkedStack s a (\s @$\rightarrow$@ s)) (\s _ @$\rightarrow$@ s) @$\equiv$@ s +push-pop-equiv s = refl + +push-and-n-pop : {A : Set} {a : A} (n : Nat) (s : SingleLinkedStack A) @$\rightarrow$@ n-pop {A} {a} (suc n) (pushSingleLinkedStack s a id) @$\equiv$@ n-pop {A} {a} n s +push-and-n-pop zero s = refl +push-and-n-pop {A} {a} (suc n) s = begin + n-pop (suc (suc n)) (pushSingleLinkedStack s a id) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + popSingleLinkedStack (n-pop (suc n) (pushSingleLinkedStack s a id)) (\s _ @$\rightarrow$@ s) + @$\equiv$@@$\langle$@ cong (\s @$\rightarrow$@ popSingleLinkedStack s (\s _ @$\rightarrow$@ s)) (push-and-n-pop n s) @$\rangle$@ + popSingleLinkedStack (n-pop n s) (\s _ @$\rightarrow$@ s) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + n-pop (suc n) s + @$\blacksquare$@ + + +n-push-pop-equiv : {A : Set} {a : A} (n : Nat) (s : SingleLinkedStack A) @$\rightarrow$@ (n-pop {A} {a} n (n-push {A} {a} n s)) @$\equiv$@ s +n-push-pop-equiv zero s = refl +n-push-pop-equiv {A} {a} (suc n) s = begin + n-pop (suc n) (n-push (suc n) s) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + n-pop (suc n) (pushSingleLinkedStack (n-push n s) a (\s @$\rightarrow$@ s)) + @$\equiv$@@$\langle$@ push-and-n-pop n (n-push n s) @$\rangle$@ + n-pop n (n-push n s) + @$\equiv$@@$\langle$@ n-push-pop-equiv n s @$\rangle$@ + s + @$\blacksquare$@ + + +n-push-pop-equiv-empty : {A : Set} {a : A} @$\rightarrow$@ (n : Nat) @$\rightarrow$@ n-pop {A} {a} n (n-push {A} {a} n emptySingleLinkedStack) @$\equiv$@ emptySingleLinkedStack +n-push-pop-equiv-empty n = n-push-pop-equiv n emptySingleLinkedStack +-} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stack-subtype-sample.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,212 @@ +module stack-subtype-sample where + +open import Level renaming (suc to S ; zero to O) +open import Function +open import Data.Nat +open import Data.Maybe +open import Relation.Binary.PropositionalEquality + +open import stack-subtype ℕ +open import subtype Context as N +open import subtype Meta as M + + +record Num : Set where + field + num : ℕ + +instance + NumIsNormalDataSegment : N.DataSegment Num + NumIsNormalDataSegment = record { get = (\c -> record { num = Context.n c}) + ; set = (\c n -> record c {n = Num.num n})} + NumIsMetaDataSegment : M.DataSegment Num + NumIsMetaDataSegment = record { get = (\m -> record {num = Context.n (Meta.context m)}) + ; set = (\m n -> record m {context = record (Meta.context m) {n = Num.num n}})} + + +plus3 : Num -> Num +plus3 record { num = n } = record {num = n + 3} + +plus3CS : N.CodeSegment Num Num +plus3CS = N.cs plus3 + + + +plus5AndPushWithPlus3 : {mc : Meta} {{_ : N.DataSegment Num}} + -> M.CodeSegment Num (Meta) +plus5AndPushWithPlus3 {mc} {{nn}} = M.cs (\n -> record {context = con n ; nextCS = (liftContext {{nn}} {{nn}} plus3CS) ; stack = st} ) + where + co = Meta.context mc + con : Num -> Context + con record { num = num } = N.DataSegment.set nn co record {num = num + 5} + st = Meta.stack mc + + + + +push-sample : {{_ : N.DataSegment Num}} {{_ : M.DataSegment Num}} -> Meta +push-sample {{nd}} {{md}} = M.exec {{md}} (plus5AndPushWithPlus3 {mc} {{nd}}) mc + where + con = record { n = 4 ; element = just 0} + code = N.cs (\c -> c) + mc = record {context = con ; stack = emptySingleLinkedStack ; nextCS = code} + + +push-sample-equiv : push-sample ≡ record { nextCS = liftContext plus3CS + ; stack = record { top = nothing} + ; context = record { n = 9} } +push-sample-equiv = refl + + +pushed-sample : {m : Meta} {{_ : N.DataSegment Num}} {{_ : M.DataSegment Num}} -> Meta +pushed-sample {m} {{nd}} {{md}} = M.exec {{md}} (M.csComp {m} {{md}} pushSingleLinkedStackCS (plus5AndPushWithPlus3 {mc} {{nd}})) mc + where + con = record { n = 4 ; element = just 0} + code = N.cs (\c -> c) + mc = record {context = con ; stack = emptySingleLinkedStack ; nextCS = code} + + + +pushed-sample-equiv : {m : Meta} -> + pushed-sample {m} ≡ record { nextCS = liftContext plus3CS + ; stack = record { top = just (cons 0 nothing) } + ; context = record { n = 12} } +pushed-sample-equiv = refl + + + +pushNum : N.CodeSegment Context Context +pushNum = N.cs pn + where + pn : Context -> Context + pn record { n = n } = record { n = pred n ; element = just n} + + +pushOnce : Meta -> Meta +pushOnce m = M.exec pushSingleLinkedStackCS m + +n-push : {m : Meta} {{_ : M.DataSegment Meta}} (n : ℕ) -> M.CodeSegment Meta Meta +n-push {{mm}} (zero) = M.cs {{mm}} {{mm}} id +n-push {m} {{mm}} (suc n) = M.cs {{mm}} {{mm}} (\m -> M.exec {{mm}} {{mm}} (n-push {m} {{mm}} n) (pushOnce m)) + +popOnce : Meta -> Meta +popOnce m = M.exec popSingleLinkedStackCS m + +n-pop : {m : Meta} {{_ : M.DataSegment Meta}} (n : ℕ) -> M.CodeSegment Meta Meta +n-pop {{mm}} (zero) = M.cs {{mm}} {{mm}} id +n-pop {m} {{mm}} (suc n) = M.cs {{mm}} {{mm}} (\m -> M.exec {{mm}} {{mm}} (n-pop {m} {{mm}} n) (popOnce m)) + + + +initMeta : ℕ -> Maybe ℕ -> N.CodeSegment Context Context -> Meta +initMeta n mn code = record { context = record { n = n ; element = mn} + ; stack = emptySingleLinkedStack + ; nextCS = code + } + +n-push-cs-exec = M.exec (n-push {meta} 3) meta + where + meta = (initMeta 5 (just 9) pushNum) + + +n-push-cs-exec-equiv : n-push-cs-exec ≡ record { nextCS = pushNum + ; context = record {n = 2 ; element = just 3} + ; stack = record {top = just (cons 4 (just (cons 5 (just (cons 9 nothing)))))}} +n-push-cs-exec-equiv = refl + + +n-pop-cs-exec = M.exec (n-pop {meta} 4) meta + where + meta = record { nextCS = N.cs id + ; context = record { n = 0 ; element = nothing} + ; stack = record {top = just (cons 9 (just (cons 8 (just (cons 7 (just (cons 6 (just (cons 5 nothing)))))))))} + } + +n-pop-cs-exec-equiv : n-pop-cs-exec ≡ record { nextCS = N.cs id + ; context = record { n = 0 ; element = just 6} + ; stack = record { top = just (cons 5 nothing)} + } + +n-pop-cs-exec-equiv = refl + + +open ≡-Reasoning + +id-meta : ℕ -> ℕ -> SingleLinkedStack ℕ -> Meta +id-meta n e s = record { context = record {n = n ; element = just e} + ; nextCS = (N.cs id) ; stack = s} + +exec-comp : (f g : M.CodeSegment Meta Meta) (m : Meta) -> M.exec (M.csComp {m} f g) m ≡ M.exec f (M.exec g m) +exec-comp (M.cs x) (M.cs _) m = refl + + +push-pop-type : ℕ -> ℕ -> ℕ -> Element ℕ -> Set₁ +push-pop-type n e x s = M.exec (M.csComp {meta} (M.cs popOnce) (M.cs pushOnce)) meta ≡ meta + where + meta = id-meta n e record {top = just (cons x (just s))} + +push-pop : (n e x : ℕ) -> (s : Element ℕ) -> push-pop-type n e x s +push-pop n e x s = refl + + + +pop-n-push-type : ℕ -> ℕ -> ℕ -> SingleLinkedStack ℕ -> Set₁ +pop-n-push-type n cn ce s = M.exec (M.csComp {meta} (M.cs popOnce) (n-push {meta} (suc n))) meta + ≡ M.exec (n-push {meta} n) meta + where + meta = id-meta cn ce s + +pop-n-push : (n cn ce : ℕ) -> (s : SingleLinkedStack ℕ) -> pop-n-push-type n cn ce s + +pop-n-push zero cn ce s = refl +pop-n-push (suc n) cn ce s = begin + M.exec (M.csComp {id-meta cn ce s} (M.cs popOnce) (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc (suc n)))) (id-meta cn ce s) + ≡⟨ refl ⟩ + M.exec (M.csComp {id-meta cn ce s} (M.cs popOnce) (M.csComp {id-meta cn ce s} (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (M.cs pushOnce))) (id-meta cn ce s) + ≡⟨ exec-comp (M.cs popOnce) (M.csComp {id-meta cn ce s} (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (M.cs pushOnce)) (id-meta cn ce s) ⟩ + M.exec (M.cs popOnce) (M.exec (M.csComp {id-meta cn ce s} (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (M.cs pushOnce)) (id-meta cn ce s)) + ≡⟨ cong (\x -> M.exec (M.cs popOnce) x) (exec-comp (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (M.cs pushOnce) (id-meta cn ce s)) ⟩ + M.exec (M.cs popOnce) (M.exec (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n))(M.exec (M.cs pushOnce) (id-meta cn ce s))) + ≡⟨ refl ⟩ + M.exec (M.cs popOnce) (M.exec (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}))) + ≡⟨ sym (exec-comp (M.cs popOnce) (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}))) ⟩ + M.exec (M.csComp {id-meta cn ce s} (M.cs popOnce) (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n))) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})) + ≡⟨ pop-n-push n cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}) ⟩ + M.exec (n-push n) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})) + ≡⟨ refl ⟩ + M.exec (n-push n) (pushOnce (id-meta cn ce s)) + ≡⟨ refl ⟩ + M.exec (n-push n) (M.exec (M.cs pushOnce) (id-meta cn ce s)) + ≡⟨ refl ⟩ + M.exec (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s) + ∎ + + + +n-push-pop-type : ℕ -> ℕ -> ℕ -> SingleLinkedStack ℕ -> Set₁ +n-push-pop-type n cn ce st = M.exec (M.csComp {meta} (n-pop {meta} n) (n-push {meta} n)) meta ≡ meta + where + meta = id-meta cn ce st + +n-push-pop : (n cn ce : ℕ) -> (s : SingleLinkedStack ℕ) -> n-push-pop-type n cn ce s +n-push-pop zero cn ce s = refl +n-push-pop (suc n) cn ce s = begin + M.exec (M.csComp {id-meta cn ce s} (n-pop {id-meta cn ce s} (suc n)) (n-push {id-meta cn ce s} (suc n))) (id-meta cn ce s) + ≡⟨ refl ⟩ + M.exec (M.csComp {id-meta cn ce s} (M.cs (\m -> M.exec (n-pop {id-meta cn ce s} n) (popOnce m))) (n-push {id-meta cn ce s} (suc n))) (id-meta cn ce s) + ≡⟨ exec-comp (M.cs (\m -> M.exec (n-pop n) (popOnce m))) (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s) ⟩ + M.exec (M.cs (\m -> M.exec (n-pop {id-meta cn ce s} n) (popOnce m))) (M.exec (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s)) + ≡⟨ refl ⟩ + M.exec (n-pop n) (popOnce (M.exec (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s))) + ≡⟨ refl ⟩ + M.exec (n-pop n) (M.exec (M.cs popOnce) (M.exec (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s))) + ≡⟨ cong (\x -> M.exec (n-pop {id-meta cn ce s} n) x) (sym (exec-comp (M.cs popOnce) (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s))) ⟩ + M.exec (n-pop n) (M.exec (M.csComp {id-meta cn ce s} (M.cs popOnce) (n-push {id-meta cn ce s} (suc n))) (id-meta cn ce s)) + ≡⟨ cong (\x -> M.exec (n-pop {id-meta cn ce s} n) x) (pop-n-push n cn ce s) ⟩ + M.exec (n-pop n) (M.exec (n-push n) (id-meta cn ce s)) + ≡⟨ sym (exec-comp (n-pop n) (n-push n) (id-meta cn ce s)) ⟩ + M.exec (M.csComp (n-pop n) (n-push n)) (id-meta cn ce s) + ≡⟨ n-push-pop n cn ce s ⟩ + id-meta cn ce s + ∎ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stack-subtype-sample.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,212 @@ +module stack-subtype-sample where + +open import Level renaming (suc to S ; zero to O) +open import Function +open import Data.Nat +open import Data.Maybe +open import Relation.Binary.PropositionalEquality + +open import stack-subtype @$\mathbb{N}$@ +open import subtype Context as N +open import subtype Meta as M + + +record Num : Set where + field + num : @$\mathbb{N}$@ + +instance + NumIsNormalDataSegment : N.DataSegment Num + NumIsNormalDataSegment = record { get = (\c @$\rightarrow$@ record { num = Context.n c}) + ; set = (\c n @$\rightarrow$@ record c {n = Num.num n})} + NumIsMetaDataSegment : M.DataSegment Num + NumIsMetaDataSegment = record { get = (\m @$\rightarrow$@ record {num = Context.n (Meta.context m)}) + ; set = (\m n @$\rightarrow$@ record m {context = record (Meta.context m) {n = Num.num n}})} + + +plus3 : Num @$\rightarrow$@ Num +plus3 record { num = n } = record {num = n + 3} + +plus3CS : N.CodeSegment Num Num +plus3CS = N.cs plus3 + + + +plus5AndPushWithPlus3 : {mc : Meta} {{_ : N.DataSegment Num}} + @$\rightarrow$@ M.CodeSegment Num (Meta) +plus5AndPushWithPlus3 {mc} {{nn}} = M.cs (\n @$\rightarrow$@ record {context = con n ; nextCS = (liftContext {{nn}} {{nn}} plus3CS) ; stack = st} ) + where + co = Meta.context mc + con : Num @$\rightarrow$@ Context + con record { num = num } = N.DataSegment.set nn co record {num = num + 5} + st = Meta.stack mc + + + + +push-sample : {{_ : N.DataSegment Num}} {{_ : M.DataSegment Num}} @$\rightarrow$@ Meta +push-sample {{nd}} {{md}} = M.exec {{md}} (plus5AndPushWithPlus3 {mc} {{nd}}) mc + where + con = record { n = 4 ; element = just 0} + code = N.cs (\c @$\rightarrow$@ c) + mc = record {context = con ; stack = emptySingleLinkedStack ; nextCS = code} + + +push-sample-equiv : push-sample @$\equiv$@ record { nextCS = liftContext plus3CS + ; stack = record { top = nothing} + ; context = record { n = 9} } +push-sample-equiv = refl + + +pushed-sample : {m : Meta} {{_ : N.DataSegment Num}} {{_ : M.DataSegment Num}} @$\rightarrow$@ Meta +pushed-sample {m} {{nd}} {{md}} = M.exec {{md}} (M.csComp {m} {{md}} pushSingleLinkedStackCS (plus5AndPushWithPlus3 {mc} {{nd}})) mc + where + con = record { n = 4 ; element = just 0} + code = N.cs (\c @$\rightarrow$@ c) + mc = record {context = con ; stack = emptySingleLinkedStack ; nextCS = code} + + + +pushed-sample-equiv : {m : Meta} @$\rightarrow$@ + pushed-sample {m} @$\equiv$@ record { nextCS = liftContext plus3CS + ; stack = record { top = just (cons 0 nothing) } + ; context = record { n = 12} } +pushed-sample-equiv = refl + + + +pushNum : N.CodeSegment Context Context +pushNum = N.cs pn + where + pn : Context @$\rightarrow$@ Context + pn record { n = n } = record { n = pred n ; element = just n} + + +pushOnce : Meta @$\rightarrow$@ Meta +pushOnce m = M.exec pushSingleLinkedStackCS m + +n-push : {m : Meta} {{_ : M.DataSegment Meta}} (n : @$\mathbb{N}$@) @$\rightarrow$@ M.CodeSegment Meta Meta +n-push {{mm}} (zero) = M.cs {{mm}} {{mm}} id +n-push {m} {{mm}} (suc n) = M.cs {{mm}} {{mm}} (\m @$\rightarrow$@ M.exec {{mm}} {{mm}} (n-push {m} {{mm}} n) (pushOnce m)) + +popOnce : Meta @$\rightarrow$@ Meta +popOnce m = M.exec popSingleLinkedStackCS m + +n-pop : {m : Meta} {{_ : M.DataSegment Meta}} (n : @$\mathbb{N}$@) @$\rightarrow$@ M.CodeSegment Meta Meta +n-pop {{mm}} (zero) = M.cs {{mm}} {{mm}} id +n-pop {m} {{mm}} (suc n) = M.cs {{mm}} {{mm}} (\m @$\rightarrow$@ M.exec {{mm}} {{mm}} (n-pop {m} {{mm}} n) (popOnce m)) + + + +initMeta : @$\mathbb{N}$@ @$\rightarrow$@ Maybe @$\mathbb{N}$@ @$\rightarrow$@ N.CodeSegment Context Context @$\rightarrow$@ Meta +initMeta n mn code = record { context = record { n = n ; element = mn} + ; stack = emptySingleLinkedStack + ; nextCS = code + } + +n-push-cs-exec = M.exec (n-push {meta} 3) meta + where + meta = (initMeta 5 (just 9) pushNum) + + +n-push-cs-exec-equiv : n-push-cs-exec @$\equiv$@ record { nextCS = pushNum + ; context = record {n = 2 ; element = just 3} + ; stack = record {top = just (cons 4 (just (cons 5 (just (cons 9 nothing)))))}} +n-push-cs-exec-equiv = refl + + +n-pop-cs-exec = M.exec (n-pop {meta} 4) meta + where + meta = record { nextCS = N.cs id + ; context = record { n = 0 ; element = nothing} + ; stack = record {top = just (cons 9 (just (cons 8 (just (cons 7 (just (cons 6 (just (cons 5 nothing)))))))))} + } + +n-pop-cs-exec-equiv : n-pop-cs-exec @$\equiv$@ record { nextCS = N.cs id + ; context = record { n = 0 ; element = just 6} + ; stack = record { top = just (cons 5 nothing)} + } + +n-pop-cs-exec-equiv = refl + + +open @$\equiv$@-Reasoning + +id-meta : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack @$\mathbb{N}$@ @$\rightarrow$@ Meta +id-meta n e s = record { context = record {n = n ; element = just e} + ; nextCS = (N.cs id) ; stack = s} + +exec-comp : (f g : M.CodeSegment Meta Meta) (m : Meta) @$\rightarrow$@ M.exec (M.csComp {m} f g) m @$\equiv$@ M.exec f (M.exec g m) +exec-comp (M.cs x) (M.cs _) m = refl + + +push-pop-type : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ Element @$\mathbb{N}$@ @$\rightarrow$@ Set@$\_{1}$@ +push-pop-type n e x s = M.exec (M.csComp {meta} (M.cs popOnce) (M.cs pushOnce)) meta @$\equiv$@ meta + where + meta = id-meta n e record {top = just (cons x (just s))} + +push-pop : (n e x : @$\mathbb{N}$@) @$\rightarrow$@ (s : Element @$\mathbb{N}$@) @$\rightarrow$@ push-pop-type n e x s +push-pop n e x s = refl + + + +pop-n-push-type : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack @$\mathbb{N}$@ @$\rightarrow$@ Set@$\_{1}$@ +pop-n-push-type n cn ce s = M.exec (M.csComp {meta} (M.cs popOnce) (n-push {meta} (suc n))) meta + @$\equiv$@ M.exec (n-push {meta} n) meta + where + meta = id-meta cn ce s + +pop-n-push : (n cn ce : @$\mathbb{N}$@) @$\rightarrow$@ (s : SingleLinkedStack @$\mathbb{N}$@) @$\rightarrow$@ pop-n-push-type n cn ce s + +pop-n-push zero cn ce s = refl +pop-n-push (suc n) cn ce s = begin + M.exec (M.csComp {id-meta cn ce s} (M.cs popOnce) (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc (suc n)))) (id-meta cn ce s) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (M.csComp {id-meta cn ce s} (M.cs popOnce) (M.csComp {id-meta cn ce s} (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (M.cs pushOnce))) (id-meta cn ce s) + @$\equiv$@@$\langle$@ exec-comp (M.cs popOnce) (M.csComp {id-meta cn ce s} (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (M.cs pushOnce)) (id-meta cn ce s) @$\rangle$@ + M.exec (M.cs popOnce) (M.exec (M.csComp {id-meta cn ce s} (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (M.cs pushOnce)) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ cong (\x @$\rightarrow$@ M.exec (M.cs popOnce) x) (exec-comp (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (M.cs pushOnce) (id-meta cn ce s)) @$\rangle$@ + M.exec (M.cs popOnce) (M.exec (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n))(M.exec (M.cs pushOnce) (id-meta cn ce s))) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (M.cs popOnce) (M.exec (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}))) + @$\equiv$@@$\langle$@ sym (exec-comp (M.cs popOnce) (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n)) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}))) @$\rangle$@ + M.exec (M.csComp {id-meta cn ce s} (M.cs popOnce) (n-push {id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})} (suc n))) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})) + @$\equiv$@@$\langle$@ pop-n-push n cn ce (record {top = just (cons ce (SingleLinkedStack.top s))}) @$\rangle$@ + M.exec (n-push n) (id-meta cn ce (record {top = just (cons ce (SingleLinkedStack.top s))})) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-push n) (pushOnce (id-meta cn ce s)) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-push n) (M.exec (M.cs pushOnce) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s) + @$\blacksquare$@ + + + +n-push-pop-type : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack @$\mathbb{N}$@ @$\rightarrow$@ Set@$\_{1}$@ +n-push-pop-type n cn ce st = M.exec (M.csComp {meta} (n-pop {meta} n) (n-push {meta} n)) meta @$\equiv$@ meta + where + meta = id-meta cn ce st + +n-push-pop : (n cn ce : @$\mathbb{N}$@) @$\rightarrow$@ (s : SingleLinkedStack @$\mathbb{N}$@) @$\rightarrow$@ n-push-pop-type n cn ce s +n-push-pop zero cn ce s = refl +n-push-pop (suc n) cn ce s = begin + M.exec (M.csComp {id-meta cn ce s} (n-pop {id-meta cn ce s} (suc n)) (n-push {id-meta cn ce s} (suc n))) (id-meta cn ce s) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (M.csComp {id-meta cn ce s} (M.cs (\m @$\rightarrow$@ M.exec (n-pop {id-meta cn ce s} n) (popOnce m))) (n-push {id-meta cn ce s} (suc n))) (id-meta cn ce s) + @$\equiv$@@$\langle$@ exec-comp (M.cs (\m @$\rightarrow$@ M.exec (n-pop n) (popOnce m))) (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s) @$\rangle$@ + M.exec (M.cs (\m @$\rightarrow$@ M.exec (n-pop {id-meta cn ce s} n) (popOnce m))) (M.exec (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-pop n) (popOnce (M.exec (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s))) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + M.exec (n-pop n) (M.exec (M.cs popOnce) (M.exec (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s))) + @$\equiv$@@$\langle$@ cong (\x @$\rightarrow$@ M.exec (n-pop {id-meta cn ce s} n) x) (sym (exec-comp (M.cs popOnce) (n-push {id-meta cn ce s} (suc n)) (id-meta cn ce s))) @$\rangle$@ + M.exec (n-pop n) (M.exec (M.csComp {id-meta cn ce s} (M.cs popOnce) (n-push {id-meta cn ce s} (suc n))) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ cong (\x @$\rightarrow$@ M.exec (n-pop {id-meta cn ce s} n) x) (pop-n-push n cn ce s) @$\rangle$@ + M.exec (n-pop n) (M.exec (n-push n) (id-meta cn ce s)) + @$\equiv$@@$\langle$@ sym (exec-comp (n-pop n) (n-push n) (id-meta cn ce s)) @$\rangle$@ + M.exec (M.csComp (n-pop n) (n-push n)) (id-meta cn ce s) + @$\equiv$@@$\langle$@ n-push-pop n cn ce s @$\rangle$@ + id-meta cn ce s + @$\blacksquare$@ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stack-subtype.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,123 @@ +open import Level hiding (lift) +open import Data.Maybe +open import Data.Product +open import Data.Nat hiding (suc) +open import Function + +module stack-subtype (A : Set) where + +-- data definitions + +data Element (a : Set) : Set where + cons : a -> Maybe (Element a) -> Element a + +datum : {a : Set} -> Element a -> a +datum (cons a _) = a + +next : {a : Set} -> Element a -> Maybe (Element a) +next (cons _ n) = n + +record SingleLinkedStack (a : Set) : Set where + field + top : Maybe (Element a) +open SingleLinkedStack + +record Context : Set where + field + -- fields for concrete data segments + n : ℕ + -- fields for stack + element : Maybe A + + + + + +open import subtype Context as N + +instance + ContextIsDataSegment : N.DataSegment Context + ContextIsDataSegment = record {get = (\c -> c) ; set = (\_ c -> c)} + + +record Meta : Set₁ where + field + -- context as set of data segments + context : Context + stack : SingleLinkedStack A + nextCS : N.CodeSegment Context Context + + + + +open import subtype Meta as M + +instance + MetaIncludeContext : M.DataSegment Context + MetaIncludeContext = record { get = Meta.context + ; set = (\m c -> record m {context = c}) } + + MetaIsMetaDataSegment : M.DataSegment Meta + MetaIsMetaDataSegment = record { get = (\m -> m) ; set = (\_ m -> m) } + + +liftMeta : {X Y : Set} {{_ : M.DataSegment X}} {{_ : M.DataSegment Y}} -> N.CodeSegment X Y -> M.CodeSegment X Y +liftMeta (N.cs f) = M.cs f + +liftContext : {X Y : Set} {{_ : N.DataSegment X}} {{_ : N.DataSegment Y}} -> N.CodeSegment X Y -> N.CodeSegment Context Context +liftContext {{x}} {{y}} (N.cs f) = N.cs (\c -> N.DataSegment.set y c (f (N.DataSegment.get x c))) + +-- definition based from Gears(209:5708390a9d88) src/parallel_execution + +emptySingleLinkedStack : SingleLinkedStack A +emptySingleLinkedStack = record {top = nothing} + + +pushSingleLinkedStack : Meta -> Meta +pushSingleLinkedStack m = M.exec (liftMeta n) (record m {stack = (push s e) }) + where + n = Meta.nextCS m + s = Meta.stack m + e = Context.element (Meta.context m) + push : SingleLinkedStack A -> Maybe A -> SingleLinkedStack A + push s nothing = s + push s (just x) = record {top = just (cons x (top s))} + + + +popSingleLinkedStack : Meta -> Meta +popSingleLinkedStack m = M.exec (liftMeta n) (record m {stack = (st m) ; context = record con {element = (elem m)}}) + where + n = Meta.nextCS m + con = Meta.context m + elem : Meta -> Maybe A + elem record {stack = record { top = (just (cons x _)) }} = just x + elem record {stack = record { top = nothing }} = nothing + st : Meta -> SingleLinkedStack A + st record {stack = record { top = (just (cons _ s)) }} = record {top = s} + st record {stack = record { top = nothing }} = record {top = nothing} + + + + +pushSingleLinkedStackCS : M.CodeSegment Meta Meta +pushSingleLinkedStackCS = M.cs pushSingleLinkedStack + +popSingleLinkedStackCS : M.CodeSegment Meta Meta +popSingleLinkedStackCS = M.cs popSingleLinkedStack + + +-- for sample + +firstContext : Context +firstContext = record {element = nothing ; n = 0} + + +firstMeta : Meta +firstMeta = record { context = firstContext + ; stack = emptySingleLinkedStack + ; nextCS = (N.cs (\m -> m)) + } + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stack-subtype.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,123 @@ +open import Level hiding (lift) +open import Data.Maybe +open import Data.Product +open import Data.Nat hiding (suc) +open import Function + +module stack-subtype (A : Set) where + +-- data definitions + +data Element (a : Set) : Set where + cons : a @$\rightarrow$@ Maybe (Element a) @$\rightarrow$@ Element a + +datum : {a : Set} @$\rightarrow$@ Element a @$\rightarrow$@ a +datum (cons a _) = a + +next : {a : Set} @$\rightarrow$@ Element a @$\rightarrow$@ Maybe (Element a) +next (cons _ n) = n + +record SingleLinkedStack (a : Set) : Set where + field + top : Maybe (Element a) +open SingleLinkedStack + +record Context : Set where + field + -- fields for concrete data segments + n : @$\mathbb{N}$@ + -- fields for stack + element : Maybe A + + + + + +open import subtype Context as N + +instance + ContextIsDataSegment : N.DataSegment Context + ContextIsDataSegment = record {get = (\c @$\rightarrow$@ c) ; set = (\_ c @$\rightarrow$@ c)} + + +record Meta : Set@$\_{1}$@ where + field + -- context as set of data segments + context : Context + stack : SingleLinkedStack A + nextCS : N.CodeSegment Context Context + + + + +open import subtype Meta as M + +instance + MetaIncludeContext : M.DataSegment Context + MetaIncludeContext = record { get = Meta.context + ; set = (\m c @$\rightarrow$@ record m {context = c}) } + + MetaIsMetaDataSegment : M.DataSegment Meta + MetaIsMetaDataSegment = record { get = (\m @$\rightarrow$@ m) ; set = (\_ m @$\rightarrow$@ m) } + + +liftMeta : {X Y : Set} {{_ : M.DataSegment X}} {{_ : M.DataSegment Y}} @$\rightarrow$@ N.CodeSegment X Y @$\rightarrow$@ M.CodeSegment X Y +liftMeta (N.cs f) = M.cs f + +liftContext : {X Y : Set} {{_ : N.DataSegment X}} {{_ : N.DataSegment Y}} @$\rightarrow$@ N.CodeSegment X Y @$\rightarrow$@ N.CodeSegment Context Context +liftContext {{x}} {{y}} (N.cs f) = N.cs (\c @$\rightarrow$@ N.DataSegment.set y c (f (N.DataSegment.get x c))) + +-- definition based from Gears(209:5708390a9d88) src/parallel_execution + +emptySingleLinkedStack : SingleLinkedStack A +emptySingleLinkedStack = record {top = nothing} + + +pushSingleLinkedStack : Meta @$\rightarrow$@ Meta +pushSingleLinkedStack m = M.exec (liftMeta n) (record m {stack = (push s e) }) + where + n = Meta.nextCS m + s = Meta.stack m + e = Context.element (Meta.context m) + push : SingleLinkedStack A @$\rightarrow$@ Maybe A @$\rightarrow$@ SingleLinkedStack A + push s nothing = s + push s (just x) = record {top = just (cons x (top s))} + + + +popSingleLinkedStack : Meta @$\rightarrow$@ Meta +popSingleLinkedStack m = M.exec (liftMeta n) (record m {stack = (st m) ; context = record con {element = (elem m)}}) + where + n = Meta.nextCS m + con = Meta.context m + elem : Meta @$\rightarrow$@ Maybe A + elem record {stack = record { top = (just (cons x _)) }} = just x + elem record {stack = record { top = nothing }} = nothing + st : Meta @$\rightarrow$@ SingleLinkedStack A + st record {stack = record { top = (just (cons _ s)) }} = record {top = s} + st record {stack = record { top = nothing }} = record {top = nothing} + + + + +pushSingleLinkedStackCS : M.CodeSegment Meta Meta +pushSingleLinkedStackCS = M.cs pushSingleLinkedStack + +popSingleLinkedStackCS : M.CodeSegment Meta Meta +popSingleLinkedStackCS = M.cs popSingleLinkedStack + + +-- for sample + +firstContext : Context +firstContext = record {element = nothing ; n = 0} + + +firstMeta : Meta +firstMeta = record { context = firstContext + ; stack = emptySingleLinkedStack + ; nextCS = (N.cs (\m @$\rightarrow$@ m)) + } + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stack.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,149 @@ +open import Level renaming (suc to succ ; zero to Zero ) +module stack where + +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Data.Nat + +ex : 1 + 2 ≡ 3 +ex = refl + +data Bool {n : Level } : Set n where + True : Bool + False : Bool + +record _∧_ {n : Level } (a : Set n) (b : Set n): Set n where + field + pi1 : a + pi2 : b + +data Maybe {n : Level } (a : Set n) : Set n where + Nothing : Maybe a + Just : a -> Maybe a + +record StackMethods {n m : Level } (a : Set n ) {t : Set m }(stackImpl : Set n ) : Set (m Level.⊔ n) where + field + push : stackImpl -> a -> (stackImpl -> t) -> t + pop : stackImpl -> (stackImpl -> Maybe a -> t) -> t + pop2 : stackImpl -> (stackImpl -> Maybe a -> Maybe a -> t) -> t + get : stackImpl -> (stackImpl -> Maybe a -> t) -> t + get2 : stackImpl -> (stackImpl -> Maybe a -> Maybe a -> t) -> t + clear : stackImpl -> (stackImpl -> t) -> t +open StackMethods + +record Stack {n m : Level } (a : Set n ) {t : Set m } (si : Set n ) : Set (m Level.⊔ n) where + field + stack : si + stackMethods : StackMethods {n} {m} a {t} si + pushStack : a -> (Stack a si -> t) -> t + pushStack d next = push (stackMethods ) (stack ) d (\s1 -> next (record {stack = s1 ; stackMethods = stackMethods } )) + popStack : (Stack a si -> Maybe a -> t) -> t + popStack next = pop (stackMethods ) (stack ) (\s1 d1 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 ) + pop2Stack : (Stack a si -> Maybe a -> Maybe a -> t) -> t + pop2Stack next = pop2 (stackMethods ) (stack ) (\s1 d1 d2 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 d2) + getStack : (Stack a si -> Maybe a -> t) -> t + getStack next = get (stackMethods ) (stack ) (\s1 d1 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 ) + get2Stack : (Stack a si -> Maybe a -> Maybe a -> t) -> t + get2Stack next = get2 (stackMethods ) (stack ) (\s1 d1 d2 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 d2) + clearStack : (Stack a si -> t) -> t + clearStack next = clear (stackMethods ) (stack ) (\s1 -> next (record {stack = s1 ; stackMethods = stackMethods } )) + +open Stack + +{-- +data Element {n : Level } (a : Set n) : Set n where + cons : a -> Maybe (Element a) -> Element a + + +datum : {n : Level } {a : Set n} -> Element a -> a +datum (cons a _) = a + +next : {n : Level } {a : Set n} -> Element a -> Maybe (Element a) +next (cons _ n) = n +--} + + +-- cannot define recrusive record definition. so use linked list with maybe. +record Element {l : Level} (a : Set l) : Set l where + inductive + constructor cons + field + datum : a -- `data` is reserved by Agda. + next : Maybe (Element a) + +open Element + + +record SingleLinkedStack {n : Level } (a : Set n) : Set n where + field + top : Maybe (Element a) +open SingleLinkedStack + +pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} -> SingleLinkedStack Data -> Data -> (Code : SingleLinkedStack Data -> t) -> t +pushSingleLinkedStack stack datum next = next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + + +popSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> t) -> t +popSingleLinkedStack stack cs with (top stack) +... | Nothing = cs stack Nothing +... | Just d = cs stack1 (Just data1) + where + data1 = datum d + stack1 = record { top = (next d) } + +pop2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t +pop2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) +... | Nothing = cs stack Nothing Nothing +... | Just d = pop2SingleLinkedStack' {n} {m} stack cs + where + pop2SingleLinkedStack' : {n m : Level } {t : Set m } -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t + pop2SingleLinkedStack' stack cs with (next d) + ... | Nothing = cs stack Nothing Nothing + ... | Just d1 = cs (record {top = (next d1)}) (Just (datum d)) (Just (datum d1)) + + +getSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> t) -> t +getSingleLinkedStack stack cs with (top stack) +... | Nothing = cs stack Nothing +... | Just d = cs stack (Just data1) + where + data1 = datum d + +get2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t +get2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) +... | Nothing = cs stack Nothing Nothing +... | Just d = get2SingleLinkedStack' {n} {m} stack cs + where + get2SingleLinkedStack' : {n m : Level} {t : Set m } -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t + get2SingleLinkedStack' stack cs with (next d) + ... | Nothing = cs stack Nothing Nothing + ... | Just d1 = cs stack (Just (datum d)) (Just (datum d1)) + +clearSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (SingleLinkedStack a -> t) -> t +clearSingleLinkedStack stack next = next (record {top = Nothing}) + + +emptySingleLinkedStack : {n : Level } {a : Set n} -> SingleLinkedStack a +emptySingleLinkedStack = record {top = Nothing} + +----- +-- Basic stack implementations are specifications of a Stack +-- +singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} -> StackMethods {n} {m} a {t} (SingleLinkedStack a) +singleLinkedStackSpec = record { + push = pushSingleLinkedStack + ; pop = popSingleLinkedStack + ; pop2 = pop2SingleLinkedStack + ; get = getSingleLinkedStack + ; get2 = get2SingleLinkedStack + ; clear = clearSingleLinkedStack + } + +createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> Stack {n} {m} a {t} (SingleLinkedStack a) +createSingleLinkedStack = record { + stack = emptySingleLinkedStack ; + stackMethods = singleLinkedStackSpec + }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stack.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,149 @@ +open import Level renaming (suc to succ ; zero to Zero ) +module stack where + +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Data.Nat + +ex : 1 + 2 @$\equiv$@ 3 +ex = refl + +data Bool {n : Level } : Set n where + True : Bool + False : Bool + +record _@$\wedge$@_ {n : Level } (a : Set n) (b : Set n): Set n where + field + pi1 : a + pi2 : b + +data Maybe {n : Level } (a : Set n) : Set n where + Nothing : Maybe a + Just : a @$\rightarrow$@ Maybe a + +record StackMethods {n m : Level } (a : Set n ) {t : Set m }(stackImpl : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + push : stackImpl @$\rightarrow$@ a @$\rightarrow$@ (stackImpl @$\rightarrow$@ t) @$\rightarrow$@ t + pop : stackImpl @$\rightarrow$@ (stackImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + pop2 : stackImpl @$\rightarrow$@ (stackImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + get : stackImpl @$\rightarrow$@ (stackImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + get2 : stackImpl @$\rightarrow$@ (stackImpl @$\rightarrow$@ Maybe a @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + clear : stackImpl @$\rightarrow$@ (stackImpl @$\rightarrow$@ t) @$\rightarrow$@ t +open StackMethods + +record Stack {n m : Level } (a : Set n ) {t : Set m } (si : Set n ) : Set (m Level.@$\sqcup$@ n) where + field + stack : si + stackMethods : StackMethods {n} {m} a {t} si + pushStack : a @$\rightarrow$@ (Stack a si @$\rightarrow$@ t) @$\rightarrow$@ t + pushStack d next = push (stackMethods ) (stack ) d (\s1 @$\rightarrow$@ next (record {stack = s1 ; stackMethods = stackMethods } )) + popStack : (Stack a si @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + popStack next = pop (stackMethods ) (stack ) (\s1 d1 @$\rightarrow$@ next (record {stack = s1 ; stackMethods = stackMethods }) d1 ) + pop2Stack : (Stack a si @$\rightarrow$@ Maybe a @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + pop2Stack next = pop2 (stackMethods ) (stack ) (\s1 d1 d2 @$\rightarrow$@ next (record {stack = s1 ; stackMethods = stackMethods }) d1 d2) + getStack : (Stack a si @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + getStack next = get (stackMethods ) (stack ) (\s1 d1 @$\rightarrow$@ next (record {stack = s1 ; stackMethods = stackMethods }) d1 ) + get2Stack : (Stack a si @$\rightarrow$@ Maybe a @$\rightarrow$@ Maybe a @$\rightarrow$@ t) @$\rightarrow$@ t + get2Stack next = get2 (stackMethods ) (stack ) (\s1 d1 d2 @$\rightarrow$@ next (record {stack = s1 ; stackMethods = stackMethods }) d1 d2) + clearStack : (Stack a si @$\rightarrow$@ t) @$\rightarrow$@ t + clearStack next = clear (stackMethods ) (stack ) (\s1 @$\rightarrow$@ next (record {stack = s1 ; stackMethods = stackMethods } )) + +open Stack + +{-- +data Element {n : Level } (a : Set n) : Set n where + cons : a @$\rightarrow$@ Maybe (Element a) @$\rightarrow$@ Element a + + +datum : {n : Level } {a : Set n} @$\rightarrow$@ Element a @$\rightarrow$@ a +datum (cons a _) = a + +next : {n : Level } {a : Set n} @$\rightarrow$@ Element a @$\rightarrow$@ Maybe (Element a) +next (cons _ n) = n +--} + + +-- cannot define recrusive record definition. so use linked list with maybe. +record Element {l : Level} (a : Set l) : Set l where + inductive + constructor cons + field + datum : a -- `data` is reserved by Agda. + next : Maybe (Element a) + +open Element + + +record SingleLinkedStack {n : Level } (a : Set n) : Set n where + field + top : Maybe (Element a) +open SingleLinkedStack + +pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} @$\rightarrow$@ SingleLinkedStack Data @$\rightarrow$@ Data @$\rightarrow$@ (Code : SingleLinkedStack Data @$\rightarrow$@ t) @$\rightarrow$@ t +pushSingleLinkedStack stack datum next = next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + + +popSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t +popSingleLinkedStack stack cs with (top stack) +... | Nothing = cs stack Nothing +... | Just d = cs stack1 (Just data1) + where + data1 = datum d + stack1 = record { top = (next d) } + +pop2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t +pop2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) +... | Nothing = cs stack Nothing Nothing +... | Just d = pop2SingleLinkedStack' {n} {m} stack cs + where + pop2SingleLinkedStack' : {n m : Level } {t : Set m } @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t + pop2SingleLinkedStack' stack cs with (next d) + ... | Nothing = cs stack Nothing Nothing + ... | Just d1 = cs (record {top = (next d1)}) (Just (datum d)) (Just (datum d1)) + + +getSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t +getSingleLinkedStack stack cs with (top stack) +... | Nothing = cs stack Nothing +... | Just d = cs stack (Just data1) + where + data1 = datum d + +get2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t +get2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) +... | Nothing = cs stack Nothing Nothing +... | Just d = get2SingleLinkedStack' {n} {m} stack cs + where + get2SingleLinkedStack' : {n m : Level} {t : Set m } @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (Code : SingleLinkedStack a @$\rightarrow$@ (Maybe a) @$\rightarrow$@ (Maybe a) @$\rightarrow$@ t) @$\rightarrow$@ t + get2SingleLinkedStack' stack cs with (next d) + ... | Nothing = cs stack Nothing Nothing + ... | Just d1 = cs stack (Just (datum d)) (Just (datum d1)) + +clearSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ (SingleLinkedStack a @$\rightarrow$@ t) @$\rightarrow$@ t +clearSingleLinkedStack stack next = next (record {top = Nothing}) + + +emptySingleLinkedStack : {n : Level } {a : Set n} @$\rightarrow$@ SingleLinkedStack a +emptySingleLinkedStack = record {top = Nothing} + +----- +-- Basic stack implementations are specifications of a Stack +-- +singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ StackMethods {n} {m} a {t} (SingleLinkedStack a) +singleLinkedStackSpec = record { + push = pushSingleLinkedStack + ; pop = popSingleLinkedStack + ; pop2 = pop2SingleLinkedStack + ; get = getSingleLinkedStack + ; get2 = get2SingleLinkedStack + ; clear = clearSingleLinkedStack + } + +createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ Stack {n} {m} a {t} (SingleLinkedStack a) +createSingleLinkedStack = record { + stack = emptySingleLinkedStack ; + stackMethods = singleLinkedStackSpec + }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stackImpl.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,38 @@ +record Element {l : Level} (a : Set l) : Set l where + inductive + constructor cons + field + datum : a -- `data` is reserved by Agda. + next : Maybe (Element a) +open Element + +record SingleLinkedStack {n : Level } (a : Set n) : Set n where + field + top : Maybe (Element a) +open SingleLinkedStack + +pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} -> SingleLinkedStack Data -> Data -> (Code : SingleLinkedStack Data -> t) -> t +pushSingleLinkedStack stack datum next = next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + +-- push 以下は省略 + +-- Basic stack implementations are specifications of a Stack + +singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} -> StackMethods {n} {m} a {t} (SingleLinkedStack a) +singleLinkedStackSpec = record { + push = pushSingleLinkedStack + ; pop = popSingleLinkedStack + ; pop2 = pop2SingleLinkedStack + ; get = getSingleLinkedStack + ; get2 = get2SingleLinkedStack + ; clear = clearSingleLinkedStack + } + +createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> Stack {n} {m} a {t} (SingleLinkedStack a) +createSingleLinkedStack = record { + stack = emptySingleLinkedStack ; + stackMethods = singleLinkedStackSpec + }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stackImpl.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,38 @@ +record Element {l : Level} (a : Set l) : Set l where + inductive + constructor cons + field + datum : a -- `data` is reserved by Agda. + next : Maybe (Element a) +open Element + +record SingleLinkedStack {n : Level } (a : Set n) : Set n where + field + top : Maybe (Element a) +open SingleLinkedStack + +pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} @$\rightarrow$@ SingleLinkedStack Data @$\rightarrow$@ Data @$\rightarrow$@ (Code : SingleLinkedStack Data @$\rightarrow$@ t) @$\rightarrow$@ t +pushSingleLinkedStack stack datum next = next stack1 + where + element = cons datum (top stack) + stack1 = record {top = Just element} + +-- push 以下は省略 + +-- Basic stack implementations are specifications of a Stack + +singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ StackMethods {n} {m} a {t} (SingleLinkedStack a) +singleLinkedStackSpec = record { + push = pushSingleLinkedStack + ; pop = popSingleLinkedStack + ; pop2 = pop2SingleLinkedStack + ; get = getSingleLinkedStack + ; get2 = get2SingleLinkedStack + ; clear = clearSingleLinkedStack + } + +createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} @$\rightarrow$@ Stack {n} {m} a {t} (SingleLinkedStack a) +createSingleLinkedStack = record { + stack = emptySingleLinkedStack ; + stackMethods = singleLinkedStackSpec + }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stackTest.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,144 @@ +open import Level renaming (suc to succ ; zero to Zero ) +module stackTest where + +open import stack + +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Data.Nat +open import Function + + +open SingleLinkedStack +open Stack + +---- +-- +-- proof of properties ( concrete cases ) +-- + +test01 : {n : Level } {a : Set n} -> SingleLinkedStack a -> Maybe a -> Bool {n} +test01 stack _ with (top stack) +... | (Just _) = True +... | Nothing = False + + +test02 : {n : Level } {a : Set n} -> SingleLinkedStack a -> Bool +test02 stack = popSingleLinkedStack stack test01 + +test03 : {n : Level } {a : Set n} -> a -> Bool +test03 v = pushSingleLinkedStack emptySingleLinkedStack v test02 + +-- after a push and a pop, the stack is empty +lemma : {n : Level} {A : Set n} {a : A} -> test03 a ≡ False +lemma = refl + +testStack01 : {n m : Level } {a : Set n} -> a -> Bool {m} +testStack01 v = pushStack createSingleLinkedStack v ( + \s -> popStack s (\s1 d1 -> True)) + +-- after push 1 and 2, pop2 get 1 and 2 + +testStack02 : {m : Level } -> ( Stack ℕ (SingleLinkedStack ℕ) -> Bool {m} ) -> Bool {m} +testStack02 cs = pushStack createSingleLinkedStack 1 ( + \s -> pushStack s 2 cs) + + +testStack031 : (d1 d2 : ℕ ) -> Bool {Zero} +testStack031 2 1 = True +testStack031 _ _ = False + +testStack032 : (d1 d2 : Maybe ℕ) -> Bool {Zero} +testStack032 (Just d1) (Just d2) = testStack031 d1 d2 +testStack032 _ _ = False + +testStack03 : {m : Level } -> Stack ℕ (SingleLinkedStack ℕ) -> ((Maybe ℕ) -> (Maybe ℕ) -> Bool {m} ) -> Bool {m} +testStack03 s cs = pop2Stack s ( + \s d1 d2 -> cs d1 d2 ) + +testStack04 : Bool +testStack04 = testStack02 (\s -> testStack03 s testStack032) + +testStack05 : testStack04 ≡ True +testStack05 = refl + +testStack06 : {m : Level } -> Maybe (Element ℕ) +testStack06 = pushStack createSingleLinkedStack 1 ( + \s -> pushStack s 2 (\s -> top (stack s))) + +testStack07 : {m : Level } -> Maybe (Element ℕ) +testStack07 = pushSingleLinkedStack emptySingleLinkedStack 1 ( + \s -> pushSingleLinkedStack s 2 (\s -> top s)) + +testStack08 = pushSingleLinkedStack emptySingleLinkedStack 1 + $ \s -> pushSingleLinkedStack s 2 + $ \s -> pushSingleLinkedStack s 3 + $ \s -> pushSingleLinkedStack s 4 + $ \s -> pushSingleLinkedStack s 5 + $ \s -> top s + +------ +-- +-- proof of properties with indefinite state of stack +-- +-- this should be proved by properties of the stack inteface, not only by the implementation, +-- and the implementation have to provides the properties. +-- +-- we cannot write "s ≡ s3", since level of the Set does not fit , but use stack s ≡ stack s3 is ok. +-- anyway some implementations may result s != s3 +-- + +stackInSomeState : {l m : Level } {D : Set l} {t : Set m } (s : SingleLinkedStack D ) -> Stack {l} {m} D {t} ( SingleLinkedStack D ) +stackInSomeState s = record { stack = s ; stackMethods = singleLinkedStackSpec } + +push->push->pop2 : {l : Level } {D : Set l} (x y : D ) (s : SingleLinkedStack D ) -> + pushStack ( stackInSomeState s ) x ( \s1 -> pushStack s1 y ( \s2 -> pop2Stack s2 ( \s3 y1 x1 -> (Just x ≡ x1 ) ∧ (Just y ≡ y1 ) ) )) +push->push->pop2 {l} {D} x y s = record { pi1 = refl ; pi2 = refl } + + +-- id : {n : Level} {A : Set n} -> A -> A +-- id a = a + +-- push a, n times + +n-push : {n : Level} {A : Set n} {a : A} -> ℕ -> SingleLinkedStack A -> SingleLinkedStack A +n-push zero s = s +n-push {l} {A} {a} (suc n) s = pushSingleLinkedStack (n-push {l} {A} {a} n s) a (\s -> s ) + +n-pop : {n : Level}{A : Set n} {a : A} -> ℕ -> SingleLinkedStack A -> SingleLinkedStack A +n-pop zero s = s +n-pop {_} {A} {a} (suc n) s = popSingleLinkedStack (n-pop {_} {A} {a} n s) (\s _ -> s ) + +open ≡-Reasoning + +push-pop-equiv : {n : Level} {A : Set n} {a : A} (s : SingleLinkedStack A) -> (popSingleLinkedStack (pushSingleLinkedStack s a (\s -> s)) (\s _ -> s) ) ≡ s +push-pop-equiv s = refl + +push-and-n-pop : {n : Level} {A : Set n} {a : A} (n : ℕ) (s : SingleLinkedStack A) -> n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack s a id) ≡ n-pop {_} {A} {a} n s +push-and-n-pop zero s = refl +push-and-n-pop {_} {A} {a} (suc n) s = begin + n-pop {_} {A} {a} (suc (suc n)) (pushSingleLinkedStack s a id) + ≡⟨ refl ⟩ + popSingleLinkedStack (n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack s a id)) (\s _ -> s) + ≡⟨ cong (\s -> popSingleLinkedStack s (\s _ -> s )) (push-and-n-pop n s) ⟩ + popSingleLinkedStack (n-pop {_} {A} {a} n s) (\s _ -> s) + ≡⟨ refl ⟩ + n-pop {_} {A} {a} (suc n) s + ∎ + + +n-push-pop-equiv : {n : Level} {A : Set n} {a : A} (n : ℕ) (s : SingleLinkedStack A) -> (n-pop {_} {A} {a} n (n-push {_} {A} {a} n s)) ≡ s +n-push-pop-equiv zero s = refl +n-push-pop-equiv {_} {A} {a} (suc n) s = begin + n-pop {_} {A} {a} (suc n) (n-push (suc n) s) + ≡⟨ refl ⟩ + n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack (n-push n s) a (\s -> s)) + ≡⟨ push-and-n-pop n (n-push n s) ⟩ + n-pop {_} {A} {a} n (n-push n s) + ≡⟨ n-push-pop-equiv n s ⟩ + s + ∎ + + +n-push-pop-equiv-empty : {n : Level} {A : Set n} {a : A} -> (n : ℕ) -> n-pop {_} {A} {a} n (n-push {_} {A} {a} n emptySingleLinkedStack) ≡ emptySingleLinkedStack +n-push-pop-equiv-empty n = n-push-pop-equiv n emptySingleLinkedStack
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stackTest.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,144 @@ +open import Level renaming (suc to succ ; zero to Zero ) +module stackTest where + +open import stack + +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Data.Nat +open import Function + + +open SingleLinkedStack +open Stack + +---- +-- +-- proof of properties ( concrete cases ) +-- + +test01 : {n : Level } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ Maybe a @$\rightarrow$@ Bool {n} +test01 stack _ with (top stack) +... | (Just _) = True +... | Nothing = False + + +test02 : {n : Level } {a : Set n} @$\rightarrow$@ SingleLinkedStack a @$\rightarrow$@ Bool +test02 stack = popSingleLinkedStack stack test01 + +test03 : {n : Level } {a : Set n} @$\rightarrow$@ a @$\rightarrow$@ Bool +test03 v = pushSingleLinkedStack emptySingleLinkedStack v test02 + +-- after a push and a pop, the stack is empty +lemma : {n : Level} {A : Set n} {a : A} @$\rightarrow$@ test03 a @$\equiv$@ False +lemma = refl + +testStack01 : {n m : Level } {a : Set n} @$\rightarrow$@ a @$\rightarrow$@ Bool {m} +testStack01 v = pushStack createSingleLinkedStack v ( + \s @$\rightarrow$@ popStack s (\s1 d1 @$\rightarrow$@ True)) + +-- after push 1 and 2, pop2 get 1 and 2 + +testStack02 : {m : Level } @$\rightarrow$@ ( Stack @$\mathbb{N}$@ (SingleLinkedStack @$\mathbb{N}$@) @$\rightarrow$@ Bool {m} ) @$\rightarrow$@ Bool {m} +testStack02 cs = pushStack createSingleLinkedStack 1 ( + \s @$\rightarrow$@ pushStack s 2 cs) + + +testStack031 : (d1 d2 : @$\mathbb{N}$@ ) @$\rightarrow$@ Bool {Zero} +testStack031 2 1 = True +testStack031 _ _ = False + +testStack032 : (d1 d2 : Maybe @$\mathbb{N}$@) @$\rightarrow$@ Bool {Zero} +testStack032 (Just d1) (Just d2) = testStack031 d1 d2 +testStack032 _ _ = False + +testStack03 : {m : Level } @$\rightarrow$@ Stack @$\mathbb{N}$@ (SingleLinkedStack @$\mathbb{N}$@) @$\rightarrow$@ ((Maybe @$\mathbb{N}$@) @$\rightarrow$@ (Maybe @$\mathbb{N}$@) @$\rightarrow$@ Bool {m} ) @$\rightarrow$@ Bool {m} +testStack03 s cs = pop2Stack s ( + \s d1 d2 @$\rightarrow$@ cs d1 d2 ) + +testStack04 : Bool +testStack04 = testStack02 (\s @$\rightarrow$@ testStack03 s testStack032) + +testStack05 : testStack04 @$\equiv$@ True +testStack05 = refl + +testStack06 : {m : Level } @$\rightarrow$@ Maybe (Element @$\mathbb{N}$@) +testStack06 = pushStack createSingleLinkedStack 1 ( + \s @$\rightarrow$@ pushStack s 2 (\s @$\rightarrow$@ top (stack s))) + +testStack07 : {m : Level } @$\rightarrow$@ Maybe (Element @$\mathbb{N}$@) +testStack07 = pushSingleLinkedStack emptySingleLinkedStack 1 ( + \s @$\rightarrow$@ pushSingleLinkedStack s 2 (\s @$\rightarrow$@ top s)) + +testStack08 = pushSingleLinkedStack emptySingleLinkedStack 1 + $ \s @$\rightarrow$@ pushSingleLinkedStack s 2 + $ \s @$\rightarrow$@ pushSingleLinkedStack s 3 + $ \s @$\rightarrow$@ pushSingleLinkedStack s 4 + $ \s @$\rightarrow$@ pushSingleLinkedStack s 5 + $ \s @$\rightarrow$@ top s + +------ +-- +-- proof of properties with indefinite state of stack +-- +-- this should be proved by properties of the stack inteface, not only by the implementation, +-- and the implementation have to provides the properties. +-- +-- we cannot write "s @$\equiv$@ s3", since level of the Set does not fit , but use stack s @$\equiv$@ stack s3 is ok. +-- anyway some implementations may result s != s3 +-- + +stackInSomeState : {l m : Level } {D : Set l} {t : Set m } (s : SingleLinkedStack D ) @$\rightarrow$@ Stack {l} {m} D {t} ( SingleLinkedStack D ) +stackInSomeState s = record { stack = s ; stackMethods = singleLinkedStackSpec } + +push@$\rightarrow$@push@$\rightarrow$@pop2 : {l : Level } {D : Set l} (x y : D ) (s : SingleLinkedStack D ) @$\rightarrow$@ + pushStack ( stackInSomeState s ) x ( \s1 @$\rightarrow$@ pushStack s1 y ( \s2 @$\rightarrow$@ pop2Stack s2 ( \s3 y1 x1 @$\rightarrow$@ (Just x @$\equiv$@ x1 ) @$\wedge$@ (Just y @$\equiv$@ y1 ) ) )) +push@$\rightarrow$@push@$\rightarrow$@pop2 {l} {D} x y s = record { pi1 = refl ; pi2 = refl } + + +-- id : {n : Level} {A : Set n} @$\rightarrow$@ A @$\rightarrow$@ A +-- id a = a + +-- push a, n times + +n-push : {n : Level} {A : Set n} {a : A} @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack A @$\rightarrow$@ SingleLinkedStack A +n-push zero s = s +n-push {l} {A} {a} (suc n) s = pushSingleLinkedStack (n-push {l} {A} {a} n s) a (\s @$\rightarrow$@ s ) + +n-pop : {n : Level}{A : Set n} {a : A} @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ SingleLinkedStack A @$\rightarrow$@ SingleLinkedStack A +n-pop zero s = s +n-pop {_} {A} {a} (suc n) s = popSingleLinkedStack (n-pop {_} {A} {a} n s) (\s _ @$\rightarrow$@ s ) + +open @$\equiv$@-Reasoning + +push-pop-equiv : {n : Level} {A : Set n} {a : A} (s : SingleLinkedStack A) @$\rightarrow$@ (popSingleLinkedStack (pushSingleLinkedStack s a (\s @$\rightarrow$@ s)) (\s _ @$\rightarrow$@ s) ) @$\equiv$@ s +push-pop-equiv s = refl + +push-and-n-pop : {n : Level} {A : Set n} {a : A} (n : @$\mathbb{N}$@) (s : SingleLinkedStack A) @$\rightarrow$@ n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack s a id) @$\equiv$@ n-pop {_} {A} {a} n s +push-and-n-pop zero s = refl +push-and-n-pop {_} {A} {a} (suc n) s = begin + n-pop {_} {A} {a} (suc (suc n)) (pushSingleLinkedStack s a id) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + popSingleLinkedStack (n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack s a id)) (\s _ @$\rightarrow$@ s) + @$\equiv$@@$\langle$@ cong (\s @$\rightarrow$@ popSingleLinkedStack s (\s _ @$\rightarrow$@ s )) (push-and-n-pop n s) @$\rangle$@ + popSingleLinkedStack (n-pop {_} {A} {a} n s) (\s _ @$\rightarrow$@ s) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + n-pop {_} {A} {a} (suc n) s + @$\blacksquare$@ + + +n-push-pop-equiv : {n : Level} {A : Set n} {a : A} (n : @$\mathbb{N}$@) (s : SingleLinkedStack A) @$\rightarrow$@ (n-pop {_} {A} {a} n (n-push {_} {A} {a} n s)) @$\equiv$@ s +n-push-pop-equiv zero s = refl +n-push-pop-equiv {_} {A} {a} (suc n) s = begin + n-pop {_} {A} {a} (suc n) (n-push (suc n) s) + @$\equiv$@@$\langle$@ refl @$\rangle$@ + n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack (n-push n s) a (\s @$\rightarrow$@ s)) + @$\equiv$@@$\langle$@ push-and-n-pop n (n-push n s) @$\rangle$@ + n-pop {_} {A} {a} n (n-push n s) + @$\equiv$@@$\langle$@ n-push-pop-equiv n s @$\rangle$@ + s + @$\blacksquare$@ + + +n-push-pop-equiv-empty : {n : Level} {A : Set n} {a : A} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ n-pop {_} {A} {a} n (n-push {_} {A} {a} n emptySingleLinkedStack) @$\equiv$@ emptySingleLinkedStack +n-push-pop-equiv-empty n = n-push-pop-equiv n emptySingleLinkedStack
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stackimpl.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,27 @@ +Stack* createSingleLinkedStack(struct Context* context) { + struct Stack* stack = new Stack(); + struct SingleLinkedStack* singleLinkedStack = new SingleLinkedStack(); + stack->stack = (union Data*)singleLinkedStack; + singleLinkedStack->top = NULL; + stack->push = C_pushSingleLinkedStack; + stack->pop = C_popSingleLinkedStack; + stack->pop2 = C_pop2SingleLinkedStack; + stack->get = C_getSingleLinkedStack; + stack->get2 = C_get2SingleLinkedStack; + stack->isEmpty = C_isEmptySingleLinkedStack; + stack->clear = C_clearSingleLinkedStack; + return stack; +} + +__code clearSingleLinkedStack(struct SingleLinkedStack* stack,__code next(...)) { + stack->top = NULL; + goto next(...); +} + +__code pushSingleLinkedStack(struct SingleLinkedStack* stack,union Data* data, __code next(...)) { + Element* element = new Element(); + element->next = stack->top; + element->data = data; + stack->top = element; + goto next(...); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stub.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,17 @@ +__code put(struct Context* context, + struct Tree* tree, + struct Node* root, + struct Allocate* allocate) +{ + /* 実装コードは省略 */ +} + +__code put_stub(struct Context* context) +{ + goto put(context, + &context->data[Tree]->tree, + context->data[Tree]->tree.root, + &context->data[Allocate]->allocate); +} + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/stubCodeGear.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,16 @@ +__code putSingleLinkedQueue(struct Context *context,struct SingleLinkedQueue* queue, union Data* data, enum Code next) { + Element* element = &ALLOCATE(context, Element)->Element; + element->data = data; + element->next = NULL; + queue->last->next = element; + queue->last = element; + goto meta(context, next); +} + +// generated by script +__code putSingleLinkedQueue_stub(struct Context* context) { + SingleLinkedQueue* queue = (SingleLinkedQueue*)GearImpl(context, Queue, queue); + Data* data = Gearef(context, Queue)->data; + enum Code next = Gearef(context, Queue)->next; + goto putSingleLinkedQueue(context, queue, data, next); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/subtype.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,44 @@ +open import Level +open import Relation.Binary.PropositionalEquality + +module subtype {l : Level} (Context : Set l) where + + +record DataSegment {ll : Level} (A : Set ll) : Set (l ⊔ ll) where + field + get : Context -> A + set : Context -> A -> Context +open DataSegment + +data CodeSegment {l1 l2 : Level} (A : Set l1) (B : Set l2) : Set (l ⊔ l1 ⊔ l2) where + cs : {{_ : DataSegment A}} {{_ : DataSegment B}} -> (A -> B) -> CodeSegment A B + +goto : {l1 l2 : Level} {I : Set l1} {O : Set l2} -> CodeSegment I O -> I -> O +goto (cs b) i = b i + +exec : {l1 l2 : Level} {I : Set l1} {O : Set l2} {{_ : DataSegment I}} {{_ : DataSegment O}} + -> CodeSegment I O -> Context -> Context +exec {l} {{i}} {{o}} (cs b) c = set o c (b (get i c)) + + +comp : {con : Context} -> {l1 l2 l3 l4 : Level} + {A : Set l1} {B : Set l2} {C : Set l3} {D : Set l4} + {{_ : DataSegment A}} {{_ : DataSegment B}} {{_ : DataSegment C}} {{_ : DataSegment D}} + -> (C -> D) -> (A -> B) -> A -> D +comp {con} {{i}} {{io}} {{oi}} {{o}} g f x = g (get oi (set io con (f x))) + +csComp : {con : Context} -> {l1 l2 l3 l4 : Level} + {A : Set l1} {B : Set l2} {C : Set l3} {D : Set l4} + {{_ : DataSegment A}} {{_ : DataSegment B}} {{_ : DataSegment C}} {{_ : DataSegment D}} + -> CodeSegment C D -> CodeSegment A B -> CodeSegment A D +csComp {con} {A} {B} {C} {D} {{da}} {{db}} {{dc}} {{dd}} (cs g) (cs f) + = cs {{da}} {{dd}} (comp {con} {{da}} {{db}} {{dc}} {{dd}} g f) + + + +comp-associative : {A B C D E F : Set l} {con : Context} + {{da : DataSegment A}} {{db : DataSegment B}} {{dc : DataSegment C}} + {{dd : DataSegment D}} {{de : DataSegment E}} {{df : DataSegment F}} + -> (a : CodeSegment A B) (b : CodeSegment C D) (c : CodeSegment E F) + -> csComp {con} c (csComp {con} b a) ≡ csComp {con} (csComp {con} c b) a +comp-associative (cs _) (cs _) (cs _) = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/subtype.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,44 @@ +open import Level +open import Relation.Binary.PropositionalEquality + +module subtype {l : Level} (Context : Set l) where + + +record DataSegment {ll : Level} (A : Set ll) : Set (l @$\sqcup$@ ll) where + field + get : Context @$\rightarrow$@ A + set : Context @$\rightarrow$@ A @$\rightarrow$@ Context +open DataSegment + +data CodeSegment {l1 l2 : Level} (A : Set l1) (B : Set l2) : Set (l @$\sqcup$@ l1 @$\sqcup$@ l2) where + cs : {{_ : DataSegment A}} {{_ : DataSegment B}} @$\rightarrow$@ (A @$\rightarrow$@ B) @$\rightarrow$@ CodeSegment A B + +goto : {l1 l2 : Level} {I : Set l1} {O : Set l2} @$\rightarrow$@ CodeSegment I O @$\rightarrow$@ I @$\rightarrow$@ O +goto (cs b) i = b i + +exec : {l1 l2 : Level} {I : Set l1} {O : Set l2} {{_ : DataSegment I}} {{_ : DataSegment O}} + @$\rightarrow$@ CodeSegment I O @$\rightarrow$@ Context @$\rightarrow$@ Context +exec {l} {{i}} {{o}} (cs b) c = set o c (b (get i c)) + + +comp : {con : Context} @$\rightarrow$@ {l1 l2 l3 l4 : Level} + {A : Set l1} {B : Set l2} {C : Set l3} {D : Set l4} + {{_ : DataSegment A}} {{_ : DataSegment B}} {{_ : DataSegment C}} {{_ : DataSegment D}} + @$\rightarrow$@ (C @$\rightarrow$@ D) @$\rightarrow$@ (A @$\rightarrow$@ B) @$\rightarrow$@ A @$\rightarrow$@ D +comp {con} {{i}} {{io}} {{oi}} {{o}} g f x = g (get oi (set io con (f x))) + +csComp : {con : Context} @$\rightarrow$@ {l1 l2 l3 l4 : Level} + {A : Set l1} {B : Set l2} {C : Set l3} {D : Set l4} + {{_ : DataSegment A}} {{_ : DataSegment B}} {{_ : DataSegment C}} {{_ : DataSegment D}} + @$\rightarrow$@ CodeSegment C D @$\rightarrow$@ CodeSegment A B @$\rightarrow$@ CodeSegment A D +csComp {con} {A} {B} {C} {D} {{da}} {{db}} {{dc}} {{dd}} (cs g) (cs f) + = cs {{da}} {{dd}} (comp {con} {{da}} {{db}} {{dc}} {{dd}} g f) + + + +comp-associative : {A B C D E F : Set l} {con : Context} + {{da : DataSegment A}} {{db : DataSegment B}} {{dc : DataSegment C}} + {{dd : DataSegment D}} {{de : DataSegment E}} {{df : DataSegment F}} + @$\rightarrow$@ (a : CodeSegment A B) (b : CodeSegment C D) (c : CodeSegment E F) + @$\rightarrow$@ csComp {con} c (csComp {con} b a) @$\equiv$@ csComp {con} (csComp {con} c b) a +comp-associative (cs _) (cs _) (cs _) = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/taskManagerInterface.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,13 @@ +typedef struct TaskManager<Impl>{ + union Data* taskManager; + struct Context* task; + struct Element* taskList; + __code spawn(Impl* taskManager, struct Context* task, __code next(...)); + __code spawnTasks(Impl* taskManagerImpl, struct Element* taskList, __code next1(...)); + __code setWaitTask(Impl* taskManagerImpl, struct Context* task, __code next(...)); + __code shutdown(Impl* taskManagerImpl, __code next(...)); + __code incrementTaskCount(Impl* taskManagerImpl, __code next(...)); + __code decrementTaskCount(Impl* taskManagerImpl, __code next(...)); + __code next(...); + __code next1(...); +} TaskManager;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/term1.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +stmt2Cond : {c10 :ℕ} → Cond +stmt2Cond {c10} env = (Equal (varn env) c10) ∧ (Equal (vari env) 0) + +lemma1 : {c10 :ℕ} → Axiom (stmt1Cond {c10}) + (λ env → record { varn = varn env ; vari = 0 }) (stmt2Cond {c10}) +lemma1 {c10} env = impl⇒ ( λ cond → let open ≡-Reasoning in + begin + ? -- ?0 + ≡⟨ ? ⟩ -- ?1 + ? -- ?2 + ∎ ) + +-- ?0 : Bool +-- ?1 : stmt2Cond (record { varn = varn env ; vari = 0 }) ≡ true +-- ?2 : Bool
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/term1.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +stmt2Cond : {c10 :@$\mathbb{N}$@} @$\rightarrow$@ Cond +stmt2Cond {c10} env = (Equal (varn env) c10) @$\wedge$@ (Equal (vari env) 0) + +lemma1 : {c10 :@$\mathbb{N}$@} @$\rightarrow$@ Axiom (stmt1Cond {c10}) + (@$\lambda$@ env @$\rightarrow$@ record { varn = varn env ; vari = 0 }) (stmt2Cond {c10}) +lemma1 {c10} env = impl@$\Rightarrow$@ ( @$\lambda$@ cond @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + ? -- ?0 + @$\equiv$@@$\langle$@ ? @$\rangle$@ -- ?1 + ? -- ?2 + @$\blacksquare$@ ) + +-- ?0 : Bool +-- ?1 : stmt2Cond (record { varn = varn env ; vari = 0 }) @$\equiv$@ true +-- ?2 : Bool
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/term2.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +∧true : { x : Bool } → x ∧ true ≡ x +∧true {x} with x +∧true {x} | false = refl +∧true {x} | true = refl + +stmt1Cond : {c10 :ℕ} → Cond +stmt1Cond {c10} env = Equal (varn env) c10
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/term2.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,7 @@ +@$\wedge$@true : { x : Bool } @$\rightarrow$@ x @$\wedge$@ true @$\equiv$@ x +@$\wedge$@true {x} with x +@$\wedge$@true {x} | false = refl +@$\wedge$@true {x} | true = refl + +stmt1Cond : {c10 :@$\mathbb{N}$@} @$\rightarrow$@ Cond +stmt1Cond {c10} env = Equal (varn env) c10
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/term3.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +lemma1 : {c10 :ℕ} → Axiom (stmt1Cond {c10}) (λ env → record { varn = varn env ; vari = 0 }) (stmt2Cond {c\ +10}) +lemma1 {c10} env = impl⇒ ( λ cond → let open ≡-Reasoning in +begin +(Equal (varn env) c10 ) ∧ true +≡⟨ ∧true ⟩ +Equal (varn env) c10 +≡⟨ cond ⟩ +true +∎ )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/term3.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +lemma1 : {c10 :@$\mathbb{N}$@} @$\rightarrow$@ Axiom (stmt1Cond {c10}) (@$\lambda$@ env @$\rightarrow$@ record { varn = varn env ; vari = 0 }) (stmt2Cond {c\ +10}) +lemma1 {c10} env = impl@$\Rightarrow$@ ( @$\lambda$@ cond @$\rightarrow$@ let open @$\equiv$@-Reasoning in +begin +(Equal (varn env) c10 ) @$\wedge$@ true +@$\equiv$@@$\langle$@ @$\wedge$@true @$\rangle$@ +Equal (varn env) c10 +@$\equiv$@@$\langle$@ cond @$\rangle$@ +true +@$\blacksquare$@ )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/termination.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ +{-# TERMINATING #-} +loop : ℕ → ℕ +loop n = loop (pred n) + +-- pred : ℕ → ℕ +-- pred zero = zero +-- pred (suc n) = n + +stop : ℕ → ℕ +stop zero = zero +stop (suc n) = (stop n)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/termination.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ +{-@$\#$@ TERMINATING @$\#$@-} +loop : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ +loop n = loop (pred n) + +-- pred : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ +-- pred zero = zero +-- pred (suc n) = n + +stop : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ +stop zero = zero +stop (suc n) = (stop n)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/tree.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +data nomal-tree (A : Set) : Set where + nleaf : (key : ℕ) → tree A + nnode : (key : ℕ) → (lnode : nomal-tree A) → (rnode : nomal-tree A) → nomal-tree A + +data meta-tree (A : Set) : (key : ℕ) → Set where + mleaf : (key : ℕ) → meta-tree A key + mnode : { l r : ℕ } → (key : ℕ) → (value : A) + → (lnode : meta-tree A l) → (rnode : meta-tree A r) + → l ≤ key → key ≤ r → metatree A key +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/tree.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,10 @@ +data nomal-tree (A : Set) : Set where + nleaf : (key : @$\mathbb{N}$@) @$\rightarrow$@ tree A + nnode : (key : @$\mathbb{N}$@) @$\rightarrow$@ (lnode : nomal-tree A) @$\rightarrow$@ (rnode : nomal-tree A) @$\rightarrow$@ nomal-tree A + +data meta-tree (A : Set) : (key : @$\mathbb{N}$@) @$\rightarrow$@ Set where + mleaf : (key : @$\mathbb{N}$@) @$\rightarrow$@ meta-tree A key + mnode : { l r : @$\mathbb{N}$@ } @$\rightarrow$@ (key : @$\mathbb{N}$@) @$\rightarrow$@ (value : A) + @$\rightarrow$@ (lnode : meta-tree A l) @$\rightarrow$@ (rnode : meta-tree A r) + @$\rightarrow$@ l @$\leq$@ key @$\rightarrow$@ key @$\leq$@ r @$\rightarrow$@ metatree A key +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/utilities.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,166 @@ +{-# OPTIONS --allow-unsolved-metas #-} +module utilities where + +open import Function +open import Data.Nat +open import Data.Product +open import Data.Bool hiding ( _≟_ ; _≤?_) +open import Level renaming ( suc to succ ; zero to Zero ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import Relation.Binary.PropositionalEquality + +Pred : Set -> Set₁ +Pred X = X -> Set + +Imply : Set -> Set -> Set +Imply X Y = X -> Y + +Iff : Set -> Set -> Set +Iff X Y = Imply X Y × Imply Y X + +record _/\_ {n : Level } (a : Set n) (b : Set n): Set n where + field + pi1 : a + pi2 : b + +open _/\_ + +_-_ : ℕ → ℕ → ℕ +x - zero = x +zero - _ = zero +(suc x) - (suc y) = x - y + ++zero : { y : ℕ } → y + zero ≡ y ++zero {zero} = refl ++zero {suc y} = cong ( λ x → suc x ) ( +zero {y} ) + + ++-sym : { x y : ℕ } → x + y ≡ y + x ++-sym {zero} {zero} = refl ++-sym {zero} {suc y} = let open ≡-Reasoning in + begin + zero + suc y + ≡⟨⟩ + suc y + ≡⟨ sym +zero ⟩ + suc y + zero + ∎ ++-sym {suc x} {zero} = let open ≡-Reasoning in + begin + suc x + zero + ≡⟨ +zero ⟩ + suc x + ≡⟨⟩ + zero + suc x + ∎ ++-sym {suc x} {suc y} = cong ( λ z → suc z ) ( let open ≡-Reasoning in + begin + x + suc y + ≡⟨ +-sym {x} {suc y} ⟩ + suc (y + x) + ≡⟨ cong ( λ z → suc z ) (+-sym {y} {x}) ⟩ + suc (x + y) + ≡⟨ sym ( +-sym {y} {suc x}) ⟩ + y + suc x + ∎ ) + + +minus-plus : { x y : ℕ } → (suc x - 1) + (y + 1) ≡ suc x + y +minus-plus {zero} {y} = +-sym {y} {1} +minus-plus {suc x} {y} = cong ( λ z → suc z ) (minus-plus {x} {y}) + ++1≡suc : { x : ℕ } → x + 1 ≡ suc x ++1≡suc {zero} = refl ++1≡suc {suc x} = cong ( λ z → suc z ) ( +1≡suc {x} ) + +lt : ℕ → ℕ → Bool +lt x y with (suc x ) ≤? y +lt x y | yes p = true +lt x y | no ¬p = false + +predℕ : {n : ℕ } → lt 0 n ≡ true → ℕ +predℕ {zero} () +predℕ {suc n} refl = n + +predℕ+1=n : {n : ℕ } → (less : lt 0 n ≡ true ) → (predℕ less) + 1 ≡ n +predℕ+1=n {zero} () +predℕ+1=n {suc n} refl = +1≡suc + +suc-predℕ=n : {n : ℕ } → (less : lt 0 n ≡ true ) → suc (predℕ less) ≡ n +suc-predℕ=n {zero} () +suc-predℕ=n {suc n} refl = refl + +Equal : ℕ → ℕ → Bool +Equal x y with x ≟ y +Equal x y | yes p = true +Equal x y | no ¬p = false + +_⇒_ : Bool → Bool → Bool +false ⇒ _ = true +true ⇒ true = true +true ⇒ false = false + +⇒t : {x : Bool} → x ⇒ true ≡ true +⇒t {x} with x +⇒t {x} | false = refl +⇒t {x} | true = refl + +f⇒ : {x : Bool} → false ⇒ x ≡ true +f⇒ {x} with x +f⇒ {x} | false = refl +f⇒ {x} | true = refl + +∧-pi1 : { x y : Bool } → x ∧ y ≡ true → x ≡ true +∧-pi1 {x} {y} eq with x | y | eq +∧-pi1 {x} {y} eq | false | b | () +∧-pi1 {x} {y} eq | true | false | () +∧-pi1 {x} {y} eq | true | true | refl = refl + +∧-pi2 : { x y : Bool } → x ∧ y ≡ true → y ≡ true +∧-pi2 {x} {y} eq with x | y | eq +∧-pi2 {x} {y} eq | false | b | () +∧-pi2 {x} {y} eq | true | false | () +∧-pi2 {x} {y} eq | true | true | refl = refl + +∧true : { x : Bool } → x ∧ true ≡ x +∧true {x} with x +∧true {x} | false = refl +∧true {x} | true = refl + +true∧ : { x : Bool } → true ∧ x ≡ x +true∧ {x} with x +true∧ {x} | false = refl +true∧ {x} | true = refl +bool-case : ( x : Bool ) { p : Set } → ( x ≡ true → p ) → ( x ≡ false → p ) → p +bool-case x T F with x +bool-case x T F | false = F refl +bool-case x T F | true = T refl + +impl⇒ : {x y : Bool} → (x ≡ true → y ≡ true ) → x ⇒ y ≡ true +impl⇒ {x} {y} p = bool-case x (λ x=t → let open ≡-Reasoning in + begin + x ⇒ y + ≡⟨ cong ( λ z → x ⇒ z ) (p x=t ) ⟩ + x ⇒ true + ≡⟨ ⇒t ⟩ + true + ∎ + ) ( λ x=f → let open ≡-Reasoning in + begin + x ⇒ y + ≡⟨ cong ( λ z → z ⇒ y ) x=f ⟩ + true + ∎ + ) + +Equal→≡ : { x y : ℕ } → Equal x y ≡ true → x ≡ y +Equal→≡ {x} {y} eq with x ≟ y +Equal→≡ {x} {y} refl | yes refl = refl +Equal→≡ {x} {y} () | no ¬p + +open import Data.Empty + +≡→Equal : { x y : ℕ } → x ≡ y → Equal x y ≡ true +≡→Equal {x} {.x} refl with x ≟ x +≡→Equal {x} {.x} refl | yes refl = refl +≡→Equal {x} {.x} refl | no ¬p = ⊥-elim ( ¬p refl )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/utilities.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,166 @@ +{-@$\#$@ OPTIONS --allow-unsolved-metas @$\#$@-} +module utilities where + +open import Function +open import Data.Nat +open import Data.Product +open import Data.Bool hiding ( _≟_ ; _@$\leq$@?_) +open import Level renaming ( suc to succ ; zero to Zero ) +open import Relation.Nullary using (@$\neg$@_; Dec; yes; no) +open import Relation.Binary.PropositionalEquality + +Pred : Set @$\rightarrow$@ Set@$\_{1}$@ +Pred X = X @$\rightarrow$@ Set + +Imply : Set @$\rightarrow$@ Set @$\rightarrow$@ Set +Imply X Y = X @$\rightarrow$@ Y + +Iff : Set @$\rightarrow$@ Set @$\rightarrow$@ Set +Iff X Y = Imply X Y @$\times$@ Imply Y X + +record _@$\wedge$@_ {n : Level } (a : Set n) (b : Set n): Set n where + field + pi1 : a + pi2 : b + +open _@$\wedge$@_ + +_-_ : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ +x - zero = x +zero - _ = zero +(suc x) - (suc y) = x - y + ++zero : { y : @$\mathbb{N}$@ } @$\rightarrow$@ y + zero @$\equiv$@ y ++zero {zero} = refl ++zero {suc y} = cong ( @$\lambda$@ x @$\rightarrow$@ suc x ) ( +zero {y} ) + + ++-sym : { x y : @$\mathbb{N}$@ } @$\rightarrow$@ x + y @$\equiv$@ y + x ++-sym {zero} {zero} = refl ++-sym {zero} {suc y} = let open @$\equiv$@-Reasoning in + begin + zero + suc y + @$\equiv$@@$\langle$@@$\rangle$@ + suc y + @$\equiv$@@$\langle$@ sym +zero @$\rangle$@ + suc y + zero + @$\blacksquare$@ ++-sym {suc x} {zero} = let open @$\equiv$@-Reasoning in + begin + suc x + zero + @$\equiv$@@$\langle$@ +zero @$\rangle$@ + suc x + @$\equiv$@@$\langle$@@$\rangle$@ + zero + suc x + @$\blacksquare$@ ++-sym {suc x} {suc y} = cong ( @$\lambda$@ z @$\rightarrow$@ suc z ) ( let open @$\equiv$@-Reasoning in + begin + x + suc y + @$\equiv$@@$\langle$@ +-sym {x} {suc y} @$\rangle$@ + suc (y + x) + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ suc z ) (+-sym {y} {x}) @$\rangle$@ + suc (x + y) + @$\equiv$@@$\langle$@ sym ( +-sym {y} {suc x}) @$\rangle$@ + y + suc x + @$\blacksquare$@ ) + + +minus-plus : { x y : @$\mathbb{N}$@ } @$\rightarrow$@ (suc x - 1) + (y + 1) @$\equiv$@ suc x + y +minus-plus {zero} {y} = +-sym {y} {1} +minus-plus {suc x} {y} = cong ( @$\lambda$@ z @$\rightarrow$@ suc z ) (minus-plus {x} {y}) + ++1@$\equiv$@suc : { x : @$\mathbb{N}$@ } @$\rightarrow$@ x + 1 @$\equiv$@ suc x ++1@$\equiv$@suc {zero} = refl ++1@$\equiv$@suc {suc x} = cong ( @$\lambda$@ z @$\rightarrow$@ suc z ) ( +1@$\equiv$@suc {x} ) + +lt : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ Bool +lt x y with (suc x ) @$\leq$@? y +lt x y | yes p = true +lt x y | no @$\neg$@p = false + +pred@$\mathbb{N}$@ : {n : @$\mathbb{N}$@ } @$\rightarrow$@ lt 0 n @$\equiv$@ true @$\rightarrow$@ @$\mathbb{N}$@ +pred@$\mathbb{N}$@ {zero} () +pred@$\mathbb{N}$@ {suc n} refl = n + +pred@$\mathbb{N}$@+1=n : {n : @$\mathbb{N}$@ } @$\rightarrow$@ (less : lt 0 n @$\equiv$@ true ) @$\rightarrow$@ (pred@$\mathbb{N}$@ less) + 1 @$\equiv$@ n +pred@$\mathbb{N}$@+1=n {zero} () +pred@$\mathbb{N}$@+1=n {suc n} refl = +1@$\equiv$@suc + +suc-pred@$\mathbb{N}$@=n : {n : @$\mathbb{N}$@ } @$\rightarrow$@ (less : lt 0 n @$\equiv$@ true ) @$\rightarrow$@ suc (pred@$\mathbb{N}$@ less) @$\equiv$@ n +suc-pred@$\mathbb{N}$@=n {zero} () +suc-pred@$\mathbb{N}$@=n {suc n} refl = refl + +Equal : @$\mathbb{N}$@ @$\rightarrow$@ @$\mathbb{N}$@ @$\rightarrow$@ Bool +Equal x y with x ≟ y +Equal x y | yes p = true +Equal x y | no @$\neg$@p = false + +_@$\Rightarrow$@_ : Bool @$\rightarrow$@ Bool @$\rightarrow$@ Bool +false @$\Rightarrow$@ _ = true +true @$\Rightarrow$@ true = true +true @$\Rightarrow$@ false = false + +@$\Rightarrow$@t : {x : Bool} @$\rightarrow$@ x @$\Rightarrow$@ true @$\equiv$@ true +@$\Rightarrow$@t {x} with x +@$\Rightarrow$@t {x} | false = refl +@$\Rightarrow$@t {x} | true = refl + +f@$\Rightarrow$@ : {x : Bool} @$\rightarrow$@ false @$\Rightarrow$@ x @$\equiv$@ true +f@$\Rightarrow$@ {x} with x +f@$\Rightarrow$@ {x} | false = refl +f@$\Rightarrow$@ {x} | true = refl + +@$\wedge$@-pi1 : { x y : Bool } @$\rightarrow$@ x @$\wedge$@ y @$\equiv$@ true @$\rightarrow$@ x @$\equiv$@ true +@$\wedge$@-pi1 {x} {y} eq with x | y | eq +@$\wedge$@-pi1 {x} {y} eq | false | b | () +@$\wedge$@-pi1 {x} {y} eq | true | false | () +@$\wedge$@-pi1 {x} {y} eq | true | true | refl = refl + +@$\wedge$@-pi2 : { x y : Bool } @$\rightarrow$@ x @$\wedge$@ y @$\equiv$@ true @$\rightarrow$@ y @$\equiv$@ true +@$\wedge$@-pi2 {x} {y} eq with x | y | eq +@$\wedge$@-pi2 {x} {y} eq | false | b | () +@$\wedge$@-pi2 {x} {y} eq | true | false | () +@$\wedge$@-pi2 {x} {y} eq | true | true | refl = refl + +@$\wedge$@true : { x : Bool } @$\rightarrow$@ x @$\wedge$@ true @$\equiv$@ x +@$\wedge$@true {x} with x +@$\wedge$@true {x} | false = refl +@$\wedge$@true {x} | true = refl + +true@$\wedge$@ : { x : Bool } @$\rightarrow$@ true @$\wedge$@ x @$\equiv$@ x +true@$\wedge$@ {x} with x +true@$\wedge$@ {x} | false = refl +true@$\wedge$@ {x} | true = refl +bool-case : ( x : Bool ) { p : Set } @$\rightarrow$@ ( x @$\equiv$@ true @$\rightarrow$@ p ) @$\rightarrow$@ ( x @$\equiv$@ false @$\rightarrow$@ p ) @$\rightarrow$@ p +bool-case x T F with x +bool-case x T F | false = F refl +bool-case x T F | true = T refl + +impl@$\Rightarrow$@ : {x y : Bool} @$\rightarrow$@ (x @$\equiv$@ true @$\rightarrow$@ y @$\equiv$@ true ) @$\rightarrow$@ x @$\Rightarrow$@ y @$\equiv$@ true +impl@$\Rightarrow$@ {x} {y} p = bool-case x (@$\lambda$@ x=t @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + x @$\Rightarrow$@ y + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ x @$\Rightarrow$@ z ) (p x=t ) @$\rangle$@ + x @$\Rightarrow$@ true + @$\equiv$@@$\langle$@ @$\Rightarrow$@t @$\rangle$@ + true + @$\blacksquare$@ + ) ( @$\lambda$@ x=f @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + x @$\Rightarrow$@ y + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ z @$\Rightarrow$@ y ) x=f @$\rangle$@ + true + @$\blacksquare$@ + ) + +Equal@$\rightarrow$@@$\equiv$@ : { x y : @$\mathbb{N}$@ } @$\rightarrow$@ Equal x y @$\equiv$@ true @$\rightarrow$@ x @$\equiv$@ y +Equal@$\rightarrow$@@$\equiv$@ {x} {y} eq with x ≟ y +Equal@$\rightarrow$@@$\equiv$@ {x} {y} refl | yes refl = refl +Equal@$\rightarrow$@@$\equiv$@ {x} {y} () | no @$\neg$@p + +open import Data.Empty + +@$\equiv$@@$\rightarrow$@Equal : { x y : @$\mathbb{N}$@ } @$\rightarrow$@ x @$\equiv$@ y @$\rightarrow$@ Equal x y @$\equiv$@ true +@$\equiv$@@$\rightarrow$@Equal {x} {.x} refl with x ≟ x +@$\equiv$@@$\rightarrow$@Equal {x} {.x} refl | yes refl = refl +@$\equiv$@@$\rightarrow$@Equal {x} {.x} refl | no @$\neg$@p = @$\bot$@-elim ( @$\neg$@p refl )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/while-test.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +whileTest : {l : Level} {t : Set l} -> (c10 : ℕ) → (Code : Env -> t) -> t +whileTest c10 next = next (record {varn = c10 ; vari = 0} )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/while-test.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,2 @@ +whileTest : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ (Code : Env @$\rightarrow$@ t) @$\rightarrow$@ t +whileTest c10 next = next (record {varn = c10 ; vari = 0} )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileConvPSemSound.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +whileConvPSemSound : {l : Level} → (input : Envc) → ((vari input ≡ 0) ∧ (varn input ≡ c)) implies (varn input + vari input ≡ c10 input) +whileConvPSemSound input = proof λ x → (conversion input x) where + conversion : (env : Envc ) → (vari env ≡ 0) /\ (varn env ≡ c10 env) → varn env + vari env ≡ c10 env + conversion e record { pi1 = refl ; pi2 = refl } = +zero
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileConvPSemSound.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +whileConvPSemSound : {l : Level} @$\rightarrow$@ (input : Envc) @$\rightarrow$@ ((vari input @$\equiv$@ 0) @$\wedge$@ (varn input @$\equiv$@ c)) implies (varn input + vari input @$\equiv$@ c10 input) +whileConvPSemSound input = proof @$\lambda$@ x @$\rightarrow$@ (conversion input x) where + conversion : (env : Envc ) @$\rightarrow$@ (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) @$\rightarrow$@ varn env + vari env @$\equiv$@ c10 env + conversion e record { pi1 = refl ; pi2 = refl } = +zero
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileLoopPSem.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,21 @@ +whileLoopPSem : {l : Level} {t : Set l} → (input : Envc ) → (vari input) + (varn input) ≡ (c10 input) +→ (next : (output : Envc ) → ((vari input) + (varn input) ≡ (c10 input) ) implies ((vari output) + (varn output) ≡ (c10 output)) → t) +→ (exit : (output : Envc ) → ((vari input) + (varn input) ≡ (c10 input) ) implies ((vari output ≡ c10 output)) → t) → t +whileLoopPSem env s next exit with varn env | s +... | zero | _ = exit env (proof (λ z → z)) +... | (suc varn ) | refl = next ( record env { varn = varn ; vari = suc (vari env) } ) (proof λ x → +-suc varn (vari env) ) + + +loopPPSem : (input output : Envc ) → output ≡ loopPP (varn input) input refl + → (vari input) + (varn input) ≡ (c10 input) → ((vari input) + (varn input) ≡ (c10 input) ) implies ((vari output ≡ c10 output)) +loopPPSem input output refl s2p = loopPPSemInduct (varn input) input refl refl s2p + where + lem : (n : ℕ) → (env : Envc) → n + suc (vari env) ≡ suc (n + vari env) + lem n env = +-suc (n) (vari env) + loopPPSemInduct : (n : ℕ) → (current : Envc) → (eq : n ≡ varn current) → (loopeq : output ≡ loopPP n current eq) + → ((vari current) + (varn current) ≡ (c10 current) ) → ((vari current) + (varn current) ≡ (c10 current) ) implies ((vari output ≡ c10 output)) + loopPPSemInduct zero current refl loopeq refl rewrite loopeq = proof (λ x → refl) + loopPPSemInduct (suc n) current refl loopeq refl rewrite (sym (lem n current)) = + whileLoopPSem current refl + (λ output x → loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + (λ output x → loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileLoopPSem.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,21 @@ +whileLoopPSem : {l : Level} {t : Set l} @$\rightarrow$@ (input : Envc ) @$\rightarrow$@ (vari input) + (varn input) @$\equiv$@ (c10 input) +@$\rightarrow$@ (next : (output : Envc ) @$\rightarrow$@ ((vari input) + (varn input) @$\equiv$@ (c10 input) ) implies ((vari output) + (varn output) @$\equiv$@ (c10 output)) @$\rightarrow$@ t) +@$\rightarrow$@ (exit : (output : Envc ) @$\rightarrow$@ ((vari input) + (varn input) @$\equiv$@ (c10 input) ) implies ((vari output @$\equiv$@ c10 output)) @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopPSem env s next exit with varn env | s +... | zero | _ = exit env (proof (@$\lambda$@ z @$\rightarrow$@ z)) +... | (suc varn ) | refl = next ( record env { varn = varn ; vari = suc (vari env) } ) (proof @$\lambda$@ x @$\rightarrow$@ +-suc varn (vari env) ) + + +loopPPSem : (input output : Envc ) @$\rightarrow$@ output @$\equiv$@ loopPP (varn input) input refl + @$\rightarrow$@ (vari input) + (varn input) @$\equiv$@ (c10 input) @$\rightarrow$@ ((vari input) + (varn input) @$\equiv$@ (c10 input) ) implies ((vari output @$\equiv$@ c10 output)) +loopPPSem input output refl s2p = loopPPSemInduct (varn input) input refl refl s2p + where + lem : (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc) @$\rightarrow$@ n + suc (vari env) @$\equiv$@ suc (n + vari env) + lem n env = +-suc (n) (vari env) + loopPPSemInduct : (n : @$\mathbb{N}$@) @$\rightarrow$@ (current : Envc) @$\rightarrow$@ (eq : n @$\equiv$@ varn current) @$\rightarrow$@ (loopeq : output @$\equiv$@ loopPP n current eq) + @$\rightarrow$@ ((vari current) + (varn current) @$\equiv$@ (c10 current) ) @$\rightarrow$@ ((vari current) + (varn current) @$\equiv$@ (c10 current) ) implies ((vari output @$\equiv$@ c10 output)) + loopPPSemInduct zero current refl loopeq refl rewrite loopeq = proof (@$\lambda$@ x @$\rightarrow$@ refl) + loopPPSemInduct (suc n) current refl loopeq refl rewrite (sym (lem n current)) = + whileLoopPSem current refl + (@$\lambda$@ output x @$\rightarrow$@ loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + (@$\lambda$@ output x @$\rightarrow$@ loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileLoopPSemSound.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,20 @@ +loopPPSem : (input output : Envc ) → output ≡ loopPP (varn input) input refl + → (whileTestStateP s2 input ) → (whileTestStateP s2 input ) implies (whileTestStateP sf output) +loopPPSem input output refl s2p = loopPPSemInduct (varn input) input refl refl s2p + where + lem : (n : ℕ) → (env : Envc) → n + suc (vari env) ≡ suc (n + vari env) + lem n env = +-suc (n) (vari env) + loopPPSemInduct : (n : ℕ) → (current : Envc) → (eq : n ≡ varn current) → (loopeq : output ≡ loopPP n current eq) + → (whileTestStateP s2 current ) → (whileTestStateP s2 current ) implies (whileTestStateP sf output) + loopPPSemInduct zero current refl loopeq refl rewrite loopeq = proof (λ x → refl) + loopPPSemInduct (suc n) current refl loopeq refl rewrite (sym (lem n current)) = + whileLoopPSem current refl + (λ output x → loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + (λ output x → loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + + +whileLoopPSemSound : {l : Level} → (input output : Envc ) + → (varn input + vari input ≡ c10 input) + → output ≡ loopPP (varn input) input refl + → (varn input + vari input ≡ c10 input) implies (vari output ≡ c10 output) +whileLoopPSemSound {l} input output pre eq = loopPPSem input output eq pre
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileLoopPSemSound.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,20 @@ +loopPPSem : (input output : Envc ) @$\rightarrow$@ output @$\equiv$@ loopPP (varn input) input refl + @$\rightarrow$@ (whileTestStateP s2 input ) @$\rightarrow$@ (whileTestStateP s2 input ) implies (whileTestStateP sf output) +loopPPSem input output refl s2p = loopPPSemInduct (varn input) input refl refl s2p + where + lem : (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc) @$\rightarrow$@ n + suc (vari env) @$\equiv$@ suc (n + vari env) + lem n env = +-suc (n) (vari env) + loopPPSemInduct : (n : @$\mathbb{N}$@) @$\rightarrow$@ (current : Envc) @$\rightarrow$@ (eq : n @$\equiv$@ varn current) @$\rightarrow$@ (loopeq : output @$\equiv$@ loopPP n current eq) + @$\rightarrow$@ (whileTestStateP s2 current ) @$\rightarrow$@ (whileTestStateP s2 current ) implies (whileTestStateP sf output) + loopPPSemInduct zero current refl loopeq refl rewrite loopeq = proof (@$\lambda$@ x @$\rightarrow$@ refl) + loopPPSemInduct (suc n) current refl loopeq refl rewrite (sym (lem n current)) = + whileLoopPSem current refl + (@$\lambda$@ output x @$\rightarrow$@ loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + (@$\lambda$@ output x @$\rightarrow$@ loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + + +whileLoopPSemSound : {l : Level} @$\rightarrow$@ (input output : Envc ) + @$\rightarrow$@ (varn input + vari input @$\equiv$@ c10 input) + @$\rightarrow$@ output @$\equiv$@ loopPP (varn input) input refl + @$\rightarrow$@ (varn input + vari input @$\equiv$@ c10 input) implies (vari output @$\equiv$@ c10 output) +whileLoopPSemSound {l} input output pre eq = loopPPSem input output eq pre
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestGears.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,276 @@ +module whileTestGears where + +open import Function +open import Data.Nat +open import Data.Bool hiding ( _≟_ ; _≤?_ ; _≤_ ; _<_) +open import Data.Product +open import Level renaming ( suc to succ ; zero to Zero ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import Relation.Binary.PropositionalEquality +open import Agda.Builtin.Unit + +open import utilities +open _/\_ + +-- original codeGear (with non terminatinng ) + +record Env : Set (succ Zero) where + field + varn : ℕ + vari : ℕ +open Env + +whileTest : {l : Level} {t : Set l} → (c10 : ℕ) → (Code : Env → t) → t +whileTest c10 next = next (record {varn = c10 ; vari = 0 } ) + +{-# TERMINATING #-} +whileLoop : {l : Level} {t : Set l} → Env → (Code : Env → t) → t +whileLoop env next with lt 0 (varn env) +whileLoop env next | false = next env +whileLoop env next | true = + whileLoop (record env {varn = (varn env) - 1 ; vari = (vari env) + 1}) next + +test1 : Env +test1 = whileTest 10 (λ env → whileLoop env (λ env1 → env1 )) + +proof1 : whileTest 10 (λ env → whileLoop env (λ e → (vari e) ≡ 10 )) +proof1 = refl + +-- codeGear with pre-condtion and post-condition +-- +-- ↓PostCondition +whileTest' : {l : Level} {t : Set l} → {c10 : ℕ } → (Code : (env : Env ) → ((vari env) ≡ 0) /\ ((varn env) ≡ c10) → t) → t +whileTest' {_} {_} {c10} next = next env proof2 + where + env : Env + env = record {vari = 0 ; varn = c10 } + proof2 : ((vari env) ≡ 0) /\ ((varn env) ≡ c10) -- PostCondition + proof2 = record {pi1 = refl ; pi2 = refl} + + +open import Data.Empty +open import Data.Nat.Properties + + +{-# TERMINATING #-} -- ↓PreCondition(Invaliant) +whileLoop' : {l : Level} {t : Set l} → (env : Env ) → {c10 : ℕ } → ((varn env) + (vari env) ≡ c10) → (Code : Env → t) → t +whileLoop' env proof next with ( suc zero ≤? (varn env) ) +whileLoop' env proof next | no p = next env +whileLoop' env {c10} proof next | yes p = whileLoop' env1 (proof3 p ) next + where + env1 = record env {varn = (varn env) - 1 ; vari = (vari env) + 1} + 1<0 : 1 ≤ zero → ⊥ + 1<0 () + proof3 : (suc zero ≤ (varn env)) → varn env1 + vari env1 ≡ c10 + proof3 (s≤s lt) with varn env + proof3 (s≤s z≤n) | zero = ⊥-elim (1<0 p) + proof3 (s≤s (z≤n {n'}) ) | suc n = let open ≡-Reasoning in + begin + n' + (vari env + 1) + ≡⟨ cong ( λ z → n' + z ) ( +-sym {vari env} {1} ) ⟩ + n' + (1 + vari env ) + ≡⟨ sym ( +-assoc (n') 1 (vari env) ) ⟩ + (n' + 1) + vari env + ≡⟨ cong ( λ z → z + vari env ) +1≡suc ⟩ + (suc n' ) + vari env + ≡⟨⟩ + varn env + vari env + ≡⟨ proof ⟩ + c10 + ∎ + +-- Condition to Invariant +conversion1 : {l : Level} {t : Set l } → (env : Env ) → {c10 : ℕ } → ((vari env) ≡ 0) /\ ((varn env) ≡ c10) + → (Code : (env1 : Env ) → (varn env1 + vari env1 ≡ c10) → t) → t +conversion1 env {c10} p1 next = next env proof4 + where + proof4 : varn env + vari env ≡ c10 + proof4 = let open ≡-Reasoning in + begin + varn env + vari env + ≡⟨ cong ( λ n → n + vari env ) (pi2 p1 ) ⟩ + c10 + vari env + ≡⟨ cong ( λ n → c10 + n ) (pi1 p1 ) ⟩ + c10 + 0 + ≡⟨ +-sym {c10} {0} ⟩ + c10 + ∎ + +-- all proofs are connected +proofGears : {c10 : ℕ } → Set +proofGears {c10} = whileTest' {_} {_} {c10} (λ n p1 → conversion1 n p1 (λ n1 p2 → whileLoop' n1 p2 (λ n2 → ( vari n2 ≡ c10 )))) + +-- +-- codeGear with loop step and closed environment +-- + +open import Relation.Binary + +record Envc : Set (succ Zero) where + field + c10 : ℕ + varn : ℕ + vari : ℕ +open Envc + +whileTestP : {l : Level} {t : Set l} → (c10 : ℕ) → (Code : Envc → t) → t +whileTestP c10 next = next (record {varn = c10 ; vari = 0 ; c10 = c10 } ) + +whileLoopP : {l : Level} {t : Set l} → Envc → (next : Envc → t) → (exit : Envc → t) → t +whileLoopP env next exit with <-cmp 0 (varn env) +whileLoopP env next exit | tri≈ ¬a b ¬c = exit env +whileLoopP env next exit | tri< a ¬b ¬c = + next (record env {varn = (varn env) - 1 ; vari = (vari env) + 1 }) + +-- equivalent of whileLoopP but it looks like an induction on varn +whileLoopP' : {l : Level} {t : Set l} → (n : ℕ) → (env : Envc) → (n ≡ varn env) → (next : Envc → t) → (exit : Envc → t) → t +whileLoopP' zero env refl _ exit = exit env +whileLoopP' (suc n) env refl next _ = next (record {c10 = (c10 env) ; varn = varn env ; vari = suc (vari env) }) + +-- normal loop without termination +{-# TERMINATING #-} +loopP : {l : Level} {t : Set l} → Envc → (exit : Envc → t) → t +loopP env exit = whileLoopP env (λ env → loopP env exit ) exit + +whileTestPCall : (c10 : ℕ ) → Envc +whileTestPCall c10 = whileTestP {_} {_} c10 (λ env → loopP env (λ env → env)) + +-- +-- codeGears with states of condition +-- +data whileTestState : Set where + s1 : whileTestState + s2 : whileTestState + sf : whileTestState + +whileTestStateP : whileTestState → Envc → Set +whileTestStateP s1 env = (vari env ≡ 0) /\ (varn env ≡ c10 env) +whileTestStateP s2 env = (varn env + vari env ≡ c10 env) +whileTestStateP sf env = (vari env ≡ c10 env) + +whileTestPwP : {l : Level} {t : Set l} → (c10 : ℕ) → ((env : Envc ) → whileTestStateP s1 env → t) → t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( λ env → env ) + +whileLoopPwP : {l : Level} {t : Set l} → (env : Envc ) → whileTestStateP s2 env + → (next : (env : Envc ) → whileTestStateP s2 env → t) + → (exit : (env : Envc ) → whileTestStateP sf env → t) → t +whileLoopPwP env s next exit with <-cmp 0 (varn env) +whileLoopPwP env s next exit | tri≈ ¬a b ¬c = exit env (lem (sym b) s) + where + lem : (varn env ≡ 0) → (varn env + vari env ≡ c10 env) → vari env ≡ c10 env + lem refl refl = refl +whileLoopPwP env s next exit | tri< a ¬b ¬c = next (record env {varn = (varn env) - 1 ; vari = (vari env) + 1 }) (proof5 a) + where + 1<0 : 1 ≤ zero → ⊥ + 1<0 () + proof5 : (suc zero ≤ (varn env)) → (varn env - 1) + (vari env + 1) ≡ c10 env + proof5 (s≤s lt) with varn env + proof5 (s≤s z≤n) | zero = ⊥-elim (1<0 a) + proof5 (s≤s (z≤n {n'}) ) | suc n = let open ≡-Reasoning in + begin + n' + (vari env + 1) + ≡⟨ cong ( λ z → n' + z ) ( +-sym {vari env} {1} ) ⟩ + n' + (1 + vari env ) + ≡⟨ sym ( +-assoc (n') 1 (vari env) ) ⟩ + (n' + 1) + vari env + ≡⟨ cong ( λ z → z + vari env ) +1≡suc ⟩ + (suc n' ) + vari env + ≡⟨⟩ + varn env + vari env + ≡⟨ s ⟩ + c10 env + ∎ + + +whileLoopPwP' : {l : Level} {t : Set l} → (n : ℕ) → (env : Envc ) → (n ≡ varn env) → whileTestStateP s2 env + → (next : (env : Envc ) → (pred n ≡ varn env) → whileTestStateP s2 env → t) + → (exit : (env : Envc ) → whileTestStateP sf env → t) → t +whileLoopPwP' zero env refl refl next exit = exit env refl +whileLoopPwP' (suc n) env refl refl next exit = next (record env {varn = pred (varn env) ; vari = suc (vari env) }) refl (+-suc n (vari env)) + + +{-# TERMINATING #-} +loopPwP : {l : Level} {t : Set l} → (env : Envc ) → whileTestStateP s2 env → (exit : (env : Envc ) → whileTestStateP sf env → t) → t +loopPwP env s exit = whileLoopPwP env s (λ env s → loopPwP env s exit ) exit + + +loopPwP' : {l : Level} {t : Set l} → (n : ℕ) → (env : Envc ) → (n ≡ varn env) → whileTestStateP s2 env → (exit : (env : Envc ) → whileTestStateP sf env → t) → t +loopPwP' zero env refl refl exit = exit env refl +loopPwP' (suc n) env refl refl exit = whileLoopPwP' (suc n) env refl refl (λ env x y → loopPwP' n env x y exit) exit + + +loopHelper : (n : ℕ) → (env : Envc ) → (eq : varn env ≡ n) → (seq : whileTestStateP s2 env) → loopPwP' n env (sym eq) seq λ env₁ x → (vari env₁ ≡ c10 env₁) +loopHelper zero env eq refl rewrite eq = refl +loopHelper (suc n) env eq refl rewrite eq = loopHelper n (record { c10 = suc (n + vari env) ; varn = n ; vari = suc (vari env) }) refl (+-suc n (vari env)) + + +-- all codtions are correctly connected and required condtion is proved in the continuation +-- use required condition as t in (env → t) → t +-- +whileTestPCallwP : (c : ℕ ) → Set +whileTestPCallwP c = whileTestPwP {_} {_} c ( λ env s → loopPwP env (conv env s) ( λ env s → vari env ≡ c10 env ) ) where + conv : (env : Envc ) → (vari env ≡ 0) /\ (varn env ≡ c10 env) → varn env + vari env ≡ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero + + +whileTestPCallwP' : (c : ℕ ) → Set +whileTestPCallwP' c = whileTestPwP {_} {_} c (λ env s → loopPwP' (varn env) env refl (conv env s) ( λ env s → vari env ≡ c10 env ) ) where + conv : (env : Envc ) → (vari env ≡ 0) /\ (varn env ≡ c10 env) → varn env + vari env ≡ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero + +helperCallwP : (c : ℕ) → whileTestPCallwP' c +helperCallwP c = whileTestPwP {_} {_} c (λ env s → loopHelper c (record { c10 = c ; varn = c ; vari = zero }) refl +zero) + +-- +-- Using imply relation to make soundness explicit +-- termination is shown by induction on varn +-- + +data _implies_ (A B : Set ) : Set (succ Zero) where + proof : ( A → B ) → A implies B + +whileTestPSem : (c : ℕ) → whileTestP c ( λ env → ⊤ implies (whileTestStateP s1 env) ) +whileTestPSem c = proof ( λ _ → record { pi1 = refl ; pi2 = refl } ) + +whileTestPSemSound : (c : ℕ ) (output : Envc ) → output ≡ whileTestP c (λ e → e) → ⊤ implies ((vari output ≡ 0) /\ (varn output ≡ c)) +whileTestPSemSound c output refl = whileTestPSem c + + +whileConvPSemSound : {l : Level} → (input : Envc) → (whileTestStateP s1 input ) implies (whileTestStateP s2 input) +whileConvPSemSound input = proof λ x → (conv input x) where + conv : (env : Envc ) → (vari env ≡ 0) /\ (varn env ≡ c10 env) → varn env + vari env ≡ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero + +loopPP : (n : ℕ) → (input : Envc ) → (n ≡ varn input) → Envc +loopPP zero input refl = input +loopPP (suc n) input refl = + loopPP n (record input { varn = pred (varn input) ; vari = suc (vari input)}) refl + +whileLoopPSem : {l : Level} {t : Set l} → (input : Envc ) → whileTestStateP s2 input + → (next : (output : Envc ) → (whileTestStateP s2 input ) implies (whileTestStateP s2 output) → t) + → (exit : (output : Envc ) → (whileTestStateP s2 input ) implies (whileTestStateP sf output) → t) → t +whileLoopPSem env s next exit with varn env | s +... | zero | _ = exit env (proof (λ z → z)) +... | (suc varn ) | refl = next ( record env { varn = varn ; vari = suc (vari env) } ) (proof λ x → +-suc varn (vari env) ) + +loopPPSem : (input output : Envc ) → output ≡ loopPP (varn input) input refl + → (whileTestStateP s2 input ) → (whileTestStateP s2 input ) implies (whileTestStateP sf output) +loopPPSem input output refl s2p = loopPPSemInduct (varn input) input refl refl s2p + where + lem : (n : ℕ) → (env : Envc) → n + suc (vari env) ≡ suc (n + vari env) + lem n env = +-suc (n) (vari env) + loopPPSemInduct : (n : ℕ) → (current : Envc) → (eq : n ≡ varn current) → (loopeq : output ≡ loopPP n current eq) + → (whileTestStateP s2 current ) → (whileTestStateP s2 current ) implies (whileTestStateP sf output) + loopPPSemInduct zero current refl loopeq refl rewrite loopeq = proof (λ x → refl) + loopPPSemInduct (suc n) current refl loopeq refl rewrite (sym (lem n current)) = + whileLoopPSem current refl + (λ output x → loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + (λ output x → loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + +whileLoopPSemSound : {l : Level} → (input output : Envc ) + → whileTestStateP s2 input + → output ≡ loopPP (varn input) input refl + → (whileTestStateP s2 input ) implies ( whileTestStateP sf output ) +whileLoopPSemSound {l} input output pre eq = loopPPSem input output eq pre
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestGears.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,276 @@ +module whileTestGears where + +open import Function +open import Data.Nat +open import Data.Bool hiding ( _@$\stackrel{?}{=}$@_ ; _@$\leq$@?_ ; _@$\leq$@_ ; _<_) +open import Data.Product +open import Level renaming ( suc to succ ; zero to Zero ) +open import Relation.Nullary using (@$\neg$@_; Dec; yes; no) +open import Relation.Binary.PropositionalEquality +open import Agda.Builtin.Unit + +open import utilities +open _@$\wedge$@_ + +-- original codeGear (with non terminatinng ) + +record Env : Set (succ Zero) where + field + varn : @$\mathbb{N}$@ + vari : @$\mathbb{N}$@ +open Env + +whileTest : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ (Code : Env @$\rightarrow$@ t) @$\rightarrow$@ t +whileTest c10 next = next (record {varn = c10 ; vari = 0 } ) + +{-@$\#$@ TERMINATING @$\#$@-} +whileLoop : {l : Level} {t : Set l} @$\rightarrow$@ Env @$\rightarrow$@ (Code : Env @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoop env next with lt 0 (varn env) +whileLoop env next | false = next env +whileLoop env next | true = + whileLoop (record env {varn = (varn env) - 1 ; vari = (vari env) + 1}) next + +test1 : Env +test1 = whileTest 10 (@$\lambda$@ env @$\rightarrow$@ whileLoop env (@$\lambda$@ env1 @$\rightarrow$@ env1 )) + +proof1 : whileTest 10 (@$\lambda$@ env @$\rightarrow$@ whileLoop env (@$\lambda$@ e @$\rightarrow$@ (vari e) @$\equiv$@ 10 )) +proof1 = refl + +-- codeGear with pre-condtion and post-condition +-- +-- ↓PostCondition +whileTest' : {l : Level} {t : Set l} @$\rightarrow$@ {c10 : @$\mathbb{N}$@ } @$\rightarrow$@ (Code : (env : Env ) @$\rightarrow$@ ((vari env) @$\equiv$@ 0) @$\wedge$@ ((varn env) @$\equiv$@ c10) @$\rightarrow$@ t) @$\rightarrow$@ t +whileTest' {_} {_} {c10} next = next env proof2 + where + env : Env + env = record {vari = 0 ; varn = c10 } + proof2 : ((vari env) @$\equiv$@ 0) @$\wedge$@ ((varn env) @$\equiv$@ c10) -- PostCondition + proof2 = record {pi1 = refl ; pi2 = refl} + + +open import Data.Empty +open import Data.Nat.Properties + + +{-@$\#$@ TERMINATING @$\#$@-} -- ↓PreCondition(Invaliant) +whileLoop' : {l : Level} {t : Set l} @$\rightarrow$@ (env : Env ) @$\rightarrow$@ {c10 : @$\mathbb{N}$@ } @$\rightarrow$@ ((varn env) + (vari env) @$\equiv$@ c10) @$\rightarrow$@ (Code : Env @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoop' env proof next with ( suc zero @$\leq$@? (varn env) ) +whileLoop' env proof next | no p = next env +whileLoop' env {c10} proof next | yes p = whileLoop' env1 (proof3 p ) next + where + env1 = record env {varn = (varn env) - 1 ; vari = (vari env) + 1} + 1<0 : 1 @$\leq$@ zero @$\rightarrow$@ @$\bot$@ + 1<0 () + proof3 : (suc zero @$\leq$@ (varn env)) @$\rightarrow$@ varn env1 + vari env1 @$\equiv$@ c10 + proof3 (s@$\leq$@s lt) with varn env + proof3 (s@$\leq$@s z@$\leq$@n) | zero = @$\bot$@-elim (1<0 p) + proof3 (s@$\leq$@s (z@$\leq$@n {n'}) ) | suc n = let open @$\equiv$@-Reasoning in + begin + n' + (vari env + 1) + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ n' + z ) ( +-sym {vari env} {1} ) @$\rangle$@ + n' + (1 + vari env ) + @$\equiv$@@$\langle$@ sym ( +-assoc (n') 1 (vari env) ) @$\rangle$@ + (n' + 1) + vari env + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ z + vari env ) +1@$\equiv$@suc @$\rangle$@ + (suc n' ) + vari env + @$\equiv$@@$\langle$@@$\rangle$@ + varn env + vari env + @$\equiv$@@$\langle$@ proof @$\rangle$@ + c10 + @$\blacksquare$@ + +-- Condition to Invariant +conversion1 : {l : Level} {t : Set l } @$\rightarrow$@ (env : Env ) @$\rightarrow$@ {c10 : @$\mathbb{N}$@ } @$\rightarrow$@ ((vari env) @$\equiv$@ 0) @$\wedge$@ ((varn env) @$\equiv$@ c10) + @$\rightarrow$@ (Code : (env1 : Env ) @$\rightarrow$@ (varn env1 + vari env1 @$\equiv$@ c10) @$\rightarrow$@ t) @$\rightarrow$@ t +conversion1 env {c10} p1 next = next env proof4 + where + proof4 : varn env + vari env @$\equiv$@ c10 + proof4 = let open @$\equiv$@-Reasoning in + begin + varn env + vari env + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ n @$\rightarrow$@ n + vari env ) (pi2 p1 ) @$\rangle$@ + c10 + vari env + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ n @$\rightarrow$@ c10 + n ) (pi1 p1 ) @$\rangle$@ + c10 + 0 + @$\equiv$@@$\langle$@ +-sym {c10} {0} @$\rangle$@ + c10 + @$\blacksquare$@ + +-- all proofs are connected +proofGears : {c10 : @$\mathbb{N}$@ } @$\rightarrow$@ Set +proofGears {c10} = whileTest' {_} {_} {c10} (@$\lambda$@ n p1 @$\rightarrow$@ conversion1 n p1 (@$\lambda$@ n1 p2 @$\rightarrow$@ whileLoop' n1 p2 (@$\lambda$@ n2 @$\rightarrow$@ ( vari n2 @$\equiv$@ c10 )))) + +-- +-- codeGear with loop step and closed environment +-- + +open import Relation.Binary + +record Envc : Set (succ Zero) where + field + c10 : @$\mathbb{N}$@ + varn : @$\mathbb{N}$@ + vari : @$\mathbb{N}$@ +open Envc + +whileTestP : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ (Code : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +whileTestP c10 next = next (record {varn = c10 ; vari = 0 ; c10 = c10 } ) + +whileLoopP : {l : Level} {t : Set l} @$\rightarrow$@ Envc @$\rightarrow$@ (next : Envc @$\rightarrow$@ t) @$\rightarrow$@ (exit : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopP env next exit with <-cmp 0 (varn env) +whileLoopP env next exit | tri@$\thickapprox$@ @$\neg$@a b @$\neg$@c = exit env +whileLoopP env next exit | tri< a @$\neg$@b @$\neg$@c = + next (record env {varn = (varn env) - 1 ; vari = (vari env) + 1 }) + +-- equivalent of whileLoopP but it looks like an induction on varn +whileLoopP' : {l : Level} {t : Set l} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc) @$\rightarrow$@ (n @$\equiv$@ varn env) @$\rightarrow$@ (next : Envc @$\rightarrow$@ t) @$\rightarrow$@ (exit : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopP' zero env refl _ exit = exit env +whileLoopP' (suc n) env refl next _ = next (record {c10 = (c10 env) ; varn = varn env ; vari = suc (vari env) }) + +-- normal loop without termination +{-@$\#$@ TERMINATING @$\#$@-} +loopP : {l : Level} {t : Set l} @$\rightarrow$@ Envc @$\rightarrow$@ (exit : Envc @$\rightarrow$@ t) @$\rightarrow$@ t +loopP env exit = whileLoopP env (@$\lambda$@ env @$\rightarrow$@ loopP env exit ) exit + +whileTestPCall : (c10 : @$\mathbb{N}$@ ) @$\rightarrow$@ Envc +whileTestPCall c10 = whileTestP {_} {_} c10 (@$\lambda$@ env @$\rightarrow$@ loopP env (@$\lambda$@ env @$\rightarrow$@ env)) + +-- +-- codeGears with states of condition +-- +data whileTestState : Set where + s1 : whileTestState + s2 : whileTestState + sf : whileTestState + +whileTestStateP : whileTestState @$\rightarrow$@ Envc @$\rightarrow$@ Set +whileTestStateP s1 env = (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) +whileTestStateP s2 env = (varn env + vari env @$\equiv$@ c10 env) +whileTestStateP sf env = (vari env @$\equiv$@ c10 env) + +whileTestPwP : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ ((env : Envc ) @$\rightarrow$@ whileTestStateP s1 env @$\rightarrow$@ t) @$\rightarrow$@ t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( @$\lambda$@ env @$\rightarrow$@ env ) + +whileLoopPwP : {l : Level} {t : Set l} @$\rightarrow$@ (env : Envc ) @$\rightarrow$@ whileTestStateP s2 env + @$\rightarrow$@ (next : (env : Envc ) @$\rightarrow$@ whileTestStateP s2 env @$\rightarrow$@ t) + @$\rightarrow$@ (exit : (env : Envc ) @$\rightarrow$@ whileTestStateP sf env @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopPwP env s next exit with <-cmp 0 (varn env) +whileLoopPwP env s next exit | tri@$\thickapprox$@ @$\neg$@a b @$\neg$@c = exit env (lem (sym b) s) + where + lem : (varn env @$\equiv$@ 0) @$\rightarrow$@ (varn env + vari env @$\equiv$@ c10 env) @$\rightarrow$@ vari env @$\equiv$@ c10 env + lem refl refl = refl +whileLoopPwP env s next exit | tri< a @$\neg$@b @$\neg$@c = next (record env {varn = (varn env) - 1 ; vari = (vari env) + 1 }) (proof5 a) + where + 1<0 : 1 @$\leq$@ zero @$\rightarrow$@ @$\bot$@ + 1<0 () + proof5 : (suc zero @$\leq$@ (varn env)) @$\rightarrow$@ (varn env - 1) + (vari env + 1) @$\equiv$@ c10 env + proof5 (s@$\leq$@s lt) with varn env + proof5 (s@$\leq$@s z@$\leq$@n) | zero = @$\bot$@-elim (1<0 a) + proof5 (s@$\leq$@s (z@$\leq$@n {n'}) ) | suc n = let open @$\equiv$@-Reasoning in + begin + n' + (vari env + 1) + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ n' + z ) ( +-sym {vari env} {1} ) @$\rangle$@ + n' + (1 + vari env ) + @$\equiv$@@$\langle$@ sym ( +-assoc (n') 1 (vari env) ) @$\rangle$@ + (n' + 1) + vari env + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ z + vari env ) +1@$\equiv$@suc @$\rangle$@ + (suc n' ) + vari env + @$\equiv$@@$\langle$@@$\rangle$@ + varn env + vari env + @$\equiv$@@$\langle$@ s @$\rangle$@ + c10 env + @$\blacksquare$@ + + +whileLoopPwP' : {l : Level} {t : Set l} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc ) @$\rightarrow$@ (n @$\equiv$@ varn env) @$\rightarrow$@ whileTestStateP s2 env + @$\rightarrow$@ (next : (env : Envc ) @$\rightarrow$@ (pred n @$\equiv$@ varn env) @$\rightarrow$@ whileTestStateP s2 env @$\rightarrow$@ t) + @$\rightarrow$@ (exit : (env : Envc ) @$\rightarrow$@ whileTestStateP sf env @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopPwP' zero env refl refl next exit = exit env refl +whileLoopPwP' (suc n) env refl refl next exit = next (record env {varn = pred (varn env) ; vari = suc (vari env) }) refl (+-suc n (vari env)) + + +{-@$\#$@ TERMINATING @$\#$@-} +loopPwP : {l : Level} {t : Set l} @$\rightarrow$@ (env : Envc ) @$\rightarrow$@ whileTestStateP s2 env @$\rightarrow$@ (exit : (env : Envc ) @$\rightarrow$@ whileTestStateP sf env @$\rightarrow$@ t) @$\rightarrow$@ t +loopPwP env s exit = whileLoopPwP env s (@$\lambda$@ env s @$\rightarrow$@ loopPwP env s exit ) exit + + +loopPwP' : {l : Level} {t : Set l} @$\rightarrow$@ (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc ) @$\rightarrow$@ (n @$\equiv$@ varn env) @$\rightarrow$@ whileTestStateP s2 env @$\rightarrow$@ (exit : (env : Envc ) @$\rightarrow$@ whileTestStateP sf env @$\rightarrow$@ t) @$\rightarrow$@ t +loopPwP' zero env refl refl exit = exit env refl +loopPwP' (suc n) env refl refl exit = whileLoopPwP' (suc n) env refl refl (@$\lambda$@ env x y @$\rightarrow$@ loopPwP' n env x y exit) exit + + +loopHelper : (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc ) @$\rightarrow$@ (eq : varn env @$\equiv$@ n) @$\rightarrow$@ (seq : whileTestStateP s2 env) @$\rightarrow$@ loopPwP' n env (sym eq) seq @$\lambda$@ env@$\_{1}$@ x @$\rightarrow$@ (vari env@$\_{1}$@ @$\equiv$@ c10 env@$\_{1}$@) +loopHelper zero env eq refl rewrite eq = refl +loopHelper (suc n) env eq refl rewrite eq = loopHelper n (record { c10 = suc (n + vari env) ; varn = n ; vari = suc (vari env) }) refl (+-suc n (vari env)) + + +-- all codtions are correctly connected and required condtion is proved in the continuation +-- use required condition as t in (env @$\rightarrow$@ t) @$\rightarrow$@ t +-- +whileTestPCallwP : (c : @$\mathbb{N}$@ ) @$\rightarrow$@ Set +whileTestPCallwP c = whileTestPwP {_} {_} c ( @$\lambda$@ env s @$\rightarrow$@ loopPwP env (conv env s) ( @$\lambda$@ env s @$\rightarrow$@ vari env @$\equiv$@ c10 env ) ) where + conv : (env : Envc ) @$\rightarrow$@ (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) @$\rightarrow$@ varn env + vari env @$\equiv$@ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero + + +whileTestPCallwP' : (c : @$\mathbb{N}$@ ) @$\rightarrow$@ Set +whileTestPCallwP' c = whileTestPwP {_} {_} c (@$\lambda$@ env s @$\rightarrow$@ loopPwP' (varn env) env refl (conv env s) ( @$\lambda$@ env s @$\rightarrow$@ vari env @$\equiv$@ c10 env ) ) where + conv : (env : Envc ) @$\rightarrow$@ (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) @$\rightarrow$@ varn env + vari env @$\equiv$@ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero + +helperCallwP : (c : @$\mathbb{N}$@) @$\rightarrow$@ whileTestPCallwP' c +helperCallwP c = whileTestPwP {_} {_} c (@$\lambda$@ env s @$\rightarrow$@ loopHelper c (record { c10 = c ; varn = c ; vari = zero }) refl +zero) + +-- +-- Using imply relation to make soundness explicit +-- termination is shown by induction on varn +-- + +data _implies_ (A B : Set ) : Set (succ Zero) where + proof : ( A @$\rightarrow$@ B ) @$\rightarrow$@ A implies B + +whileTestPSem : (c : @$\mathbb{N}$@) @$\rightarrow$@ whileTestP c ( @$\lambda$@ env @$\rightarrow$@ @$\top$@ implies (whileTestStateP s1 env) ) +whileTestPSem c = proof ( @$\lambda$@ _ @$\rightarrow$@ record { pi1 = refl ; pi2 = refl } ) + +whileTestPSemSound : (c : @$\mathbb{N}$@ ) (output : Envc ) @$\rightarrow$@ output @$\equiv$@ whileTestP c (@$\lambda$@ e @$\rightarrow$@ e) @$\rightarrow$@ @$\top$@ implies ((vari output @$\equiv$@ 0) @$\wedge$@ (varn output @$\equiv$@ c)) +whileTestPSemSound c output refl = whileTestPSem c + + +whileConvPSemSound : {l : Level} @$\rightarrow$@ (input : Envc) @$\rightarrow$@ (whileTestStateP s1 input ) implies (whileTestStateP s2 input) +whileConvPSemSound input = proof @$\lambda$@ x @$\rightarrow$@ (conv input x) where + conv : (env : Envc ) @$\rightarrow$@ (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) @$\rightarrow$@ varn env + vari env @$\equiv$@ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero + +loopPP : (n : @$\mathbb{N}$@) @$\rightarrow$@ (input : Envc ) @$\rightarrow$@ (n @$\equiv$@ varn input) @$\rightarrow$@ Envc +loopPP zero input refl = input +loopPP (suc n) input refl = + loopPP n (record input { varn = pred (varn input) ; vari = suc (vari input)}) refl + +whileLoopPSem : {l : Level} {t : Set l} @$\rightarrow$@ (input : Envc ) @$\rightarrow$@ whileTestStateP s2 input + @$\rightarrow$@ (next : (output : Envc ) @$\rightarrow$@ (whileTestStateP s2 input ) implies (whileTestStateP s2 output) @$\rightarrow$@ t) + @$\rightarrow$@ (exit : (output : Envc ) @$\rightarrow$@ (whileTestStateP s2 input ) implies (whileTestStateP sf output) @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopPSem env s next exit with varn env | s +... | zero | _ = exit env (proof (@$\lambda$@ z @$\rightarrow$@ z)) +... | (suc varn ) | refl = next ( record env { varn = varn ; vari = suc (vari env) } ) (proof @$\lambda$@ x @$\rightarrow$@ +-suc varn (vari env) ) + +loopPPSem : (input output : Envc ) @$\rightarrow$@ output @$\equiv$@ loopPP (varn input) input refl + @$\rightarrow$@ (whileTestStateP s2 input ) @$\rightarrow$@ (whileTestStateP s2 input ) implies (whileTestStateP sf output) +loopPPSem input output refl s2p = loopPPSemInduct (varn input) input refl refl s2p + where + lem : (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc) @$\rightarrow$@ n + suc (vari env) @$\equiv$@ suc (n + vari env) + lem n env = +-suc (n) (vari env) + loopPPSemInduct : (n : @$\mathbb{N}$@) @$\rightarrow$@ (current : Envc) @$\rightarrow$@ (eq : n @$\equiv$@ varn current) @$\rightarrow$@ (loopeq : output @$\equiv$@ loopPP n current eq) + @$\rightarrow$@ (whileTestStateP s2 current ) @$\rightarrow$@ (whileTestStateP s2 current ) implies (whileTestStateP sf output) + loopPPSemInduct zero current refl loopeq refl rewrite loopeq = proof (@$\lambda$@ x @$\rightarrow$@ refl) + loopPPSemInduct (suc n) current refl loopeq refl rewrite (sym (lem n current)) = + whileLoopPSem current refl + (@$\lambda$@ output x @$\rightarrow$@ loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + (@$\lambda$@ output x @$\rightarrow$@ loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + +whileLoopPSemSound : {l : Level} @$\rightarrow$@ (input output : Envc ) + @$\rightarrow$@ whileTestStateP s2 input + @$\rightarrow$@ output @$\equiv$@ loopPP (varn input) input refl + @$\rightarrow$@ (whileTestStateP s2 input ) implies ( whileTestStateP sf output ) +whileLoopPSemSound {l} input output pre eq = loopPPSem input output eq pre
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestPSem.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +whileTestPSem : (c : ℕ) → whileTestP c + ( λ env → ⊤ implies (vari env ≡ 0) ∧ (varn env ≡ c10 env) ) +whileTestPSem c = proof ( λ _ → record { pi1 = refl ; pi2 = refl } )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestPSem.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,3 @@ +whileTestPSem : (c : @$\mathbb{N}$@) @$\rightarrow$@ whileTestP c + ( @$\lambda$@ env @$\rightarrow$@ ⊤ implies (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) ) +whileTestPSem c = proof ( @$\lambda$@ _ @$\rightarrow$@ record { pi1 = refl ; pi2 = refl } )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestPrim.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,71 @@ +module whileTestPrim where + +open import Function +open import Data.Nat +open import Data.Bool hiding ( _≟_ ) +open import Level renaming ( suc to succ ; zero to Zero ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import Relation.Binary.PropositionalEquality + +open import utilities hiding ( _/\_ ) + +record Env : Set where + field + varn : ℕ + vari : ℕ +open Env + +PrimComm : Set +PrimComm = Env → Env + +Cond : Set +Cond = (Env → Bool) + +Axiom : Cond -> PrimComm -> Cond -> Set +Axiom pre comm post = ∀ (env : Env) → (pre env) ⇒ ( post (comm env)) ≡ true + +Tautology : Cond -> Cond -> Set +Tautology pre post = ∀ (env : Env) → (pre env) ⇒ (post env) ≡ true + +_and_ : Cond -> Cond -> Cond +x and y = λ env → x env ∧ y env + +neg : Cond -> Cond +neg x = λ env → not ( x env ) + +open import Hoare PrimComm Cond Axiom Tautology _and_ neg + +--------------------------- + +program : ℕ → Comm +program c10 = + Seq ( PComm (λ env → record env {varn = c10})) + $ Seq ( PComm (λ env → record env {vari = 0})) + $ While (λ env → lt zero (varn env ) ) + (Seq (PComm (λ env → record env {vari = ((vari env) + 1)} )) + $ PComm (λ env → record env {varn = ((varn env) - 1)} )) + +simple : ℕ → Comm +simple c10 = + Seq ( PComm (λ env → record env {varn = c10})) + $ PComm (λ env → record env {vari = 0}) + +{-# TERMINATING #-} +interpret : Env → Comm → Env +interpret env Skip = env +interpret env Abort = env +interpret env (PComm x) = x env +interpret env (Seq comm comm1) = interpret (interpret env comm) comm1 +interpret env (If x then else) with x env +... | true = interpret env then +... | false = interpret env else +interpret env (While x comm) with x env +... | true = interpret (interpret env comm) (While x comm) +... | false = env + +test1 : Env +test1 = interpret ( record { vari = 0 ; varn = 0 } ) (program 10) + + +tests : Env +tests = interpret ( record { vari = 0 ; varn = 0 } ) (simple 10)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestPrim.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,71 @@ +module whileTestPrim where + +open import Function +open import Data.Nat +open import Data.Bool hiding ( _@$\stackrel{?}{=}$@_ ) +open import Level renaming ( suc to succ ; zero to Zero ) +open import Relation.Nullary using (@$\neg$@_; Dec; yes; no) +open import Relation.Binary.PropositionalEquality + +open import utilities hiding ( _@$\wedge$@_ ) + +record Env : Set where + field + varn : @$\mathbb{N}$@ + vari : @$\mathbb{N}$@ +open Env + +PrimComm : Set +PrimComm = Env @$\rightarrow$@ Env + +Cond : Set +Cond = (Env @$\rightarrow$@ Bool) + +Axiom : Cond @$\rightarrow$@ PrimComm @$\rightarrow$@ Cond @$\rightarrow$@ Set +Axiom pre comm post = @$\forall$@ (env : Env) @$\rightarrow$@ (pre env) @$\Rightarrow$@ ( post (comm env)) @$\equiv$@ true + +Tautology : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Set +Tautology pre post = @$\forall$@ (env : Env) @$\rightarrow$@ (pre env) @$\Rightarrow$@ (post env) @$\equiv$@ true + +_and_ : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Cond +x and y = @$\lambda$@ env @$\rightarrow$@ x env @$\wedge$@ y env + +neg : Cond @$\rightarrow$@ Cond +neg x = @$\lambda$@ env @$\rightarrow$@ not ( x env ) + +open import Hoare PrimComm Cond Axiom Tautology _and_ neg + +--------------------------- + +program : @$\mathbb{N}$@ @$\rightarrow$@ Comm +program c10 = + Seq ( PComm (@$\lambda$@ env @$\rightarrow$@ record env {varn = c10})) + $ Seq ( PComm (@$\lambda$@ env @$\rightarrow$@ record env {vari = 0})) + $ While (@$\lambda$@ env @$\rightarrow$@ lt zero (varn env ) ) + (Seq (PComm (@$\lambda$@ env @$\rightarrow$@ record env {vari = ((vari env) + 1)} )) + $ PComm (@$\lambda$@ env @$\rightarrow$@ record env {varn = ((varn env) - 1)} )) + +simple : @$\mathbb{N}$@ @$\rightarrow$@ Comm +simple c10 = + Seq ( PComm (@$\lambda$@ env @$\rightarrow$@ record env {varn = c10})) + $ PComm (@$\lambda$@ env @$\rightarrow$@ record env {vari = 0}) + +{-@$\#$@ TERMINATING @$\#$@-} +interpret : Env @$\rightarrow$@ Comm @$\rightarrow$@ Env +interpret env Skip = env +interpret env Abort = env +interpret env (PComm x) = x env +interpret env (Seq comm comm1) = interpret (interpret env comm) comm1 +interpret env (If x then else) with x env +... | true = interpret env then +... | false = interpret env else +interpret env (While x comm) with x env +... | true = interpret (interpret env comm) (While x comm) +... | false = env + +test1 : Env +test1 = interpret ( record { vari = 0 ; varn = 0 } ) (program 10) + + +tests : Env +tests = interpret ( record { vari = 0 ; varn = 0 } ) (simple 10)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestPrimProof.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,288 @@ +module whileTestPrimProof where + +open import Function +open import Data.Nat +open import Data.Bool hiding ( _≟_ ) +open import Level renaming ( suc to succ ; zero to Zero ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import Relation.Binary.PropositionalEquality + +open import utilities hiding ( _/\_ ) +open import whileTestPrim + +open import Hoare PrimComm Cond Axiom Tautology _and_ neg + +open Env + +initCond : Cond +initCond env = true + +stmt1Cond : {c10 : ℕ} → Cond +stmt1Cond {c10} env = Equal (varn env) c10 + +init-case : {c10 : ℕ} → (env : Env) → (( λ e → true ⇒ stmt1Cond {c10} e ) (record { varn = c10 ; vari = vari env }) ) ≡ true +init-case {c10} _ = impl⇒ ( λ cond → ≡→Equal refl ) + +init-type : {c10 : ℕ} → Axiom (λ env → true) (λ env → record { varn = c10 ; vari = vari env }) (stmt1Cond {c10}) +init-type {c10} env = init-case env + +stmt2Cond : {c10 : ℕ} → Cond +stmt2Cond {c10} env = (Equal (varn env) c10) ∧ (Equal (vari env) 0) + +lemma1 : {c10 : ℕ} → Axiom (stmt1Cond {c10}) (λ env → record { varn = varn env ; vari = 0 }) (stmt2Cond {c10}) +lemma1 {c10} env = impl⇒ ( λ cond → let open ≡-Reasoning in + begin + (Equal (varn env) c10 ) ∧ true + ≡⟨ ∧true ⟩ + Equal (varn env) c10 + ≡⟨ cond ⟩ + true + ∎ ) + +-- simple : ℕ → Comm +-- simple c10 = +-- Seq ( PComm (λ env → record env {varn = c10})) +-- $ PComm (λ env → record env {vari = 0}) + +proofs : (c10 : ℕ) → HTProof initCond (simple c10) (stmt2Cond {c10}) +proofs c10 = + SeqRule {initCond} ( PrimRule (init-case {c10} )) + $ PrimRule {stmt1Cond} {_} {stmt2Cond} (lemma1 {c10}) + +open import Data.Empty + +open import Data.Nat.Properties + +whileInv : {c10 : ℕ} → Cond +whileInv {c10} env = Equal ((varn env) + (vari env)) c10 + +whileInv' : {c10 : ℕ} → Cond +whileInv'{c10} env = Equal ((varn env) + (vari env)) (suc c10) ∧ lt zero (varn env) + +termCond : {c10 : ℕ} → Cond +termCond {c10} env = Equal (vari env) c10 + + +-- program : ℕ → Comm +-- program c10 = +-- Seq ( PComm (λ env → record env {varn = c10})) +-- $ Seq ( PComm (λ env → record env {vari = 0})) +-- $ While (λ env → lt zero (varn env ) ) +-- (Seq (PComm (λ env → record env {vari = ((vari env) + 1)} )) +-- $ PComm (λ env → record env {varn = ((varn env) - 1)} )) + + +proof1 : (c10 : ℕ) → HTProof initCond (program c10 ) (termCond {c10}) +proof1 c10 = + SeqRule {λ e → true} ( PrimRule (init-case {c10} )) + $ SeqRule {λ e → Equal (varn e) c10} ( PrimRule lemma1 ) + $ WeakeningRule {λ e → (Equal (varn e) c10) ∧ (Equal (vari e) 0)} lemma2 ( + WhileRule {_} {λ e → Equal ((varn e) + (vari e)) c10} + $ SeqRule (PrimRule {λ e → whileInv e ∧ lt zero (varn e) } lemma3 ) + $ PrimRule {whileInv'} {_} {whileInv} lemma4 ) lemma5 + where + lemma21 : {env : Env } → {c10 : ℕ} → stmt2Cond env ≡ true → varn env ≡ c10 + lemma21 eq = Equal→≡ (∧-pi1 eq) + lemma22 : {env : Env } → {c10 : ℕ} → stmt2Cond {c10} env ≡ true → vari env ≡ 0 + lemma22 eq = Equal→≡ (∧-pi2 eq) + lemma23 : {env : Env } → {c10 : ℕ} → stmt2Cond env ≡ true → varn env + vari env ≡ c10 + lemma23 {env} {c10} eq = let open ≡-Reasoning in + begin + varn env + vari env + ≡⟨ cong ( \ x -> x + vari env ) (lemma21 eq ) ⟩ + c10 + vari env + ≡⟨ cong ( \ x -> c10 + x) (lemma22 {env} {c10} eq ) ⟩ + c10 + 0 + ≡⟨ +-sym {c10} {0} ⟩ + 0 + c10 + ≡⟨⟩ + c10 + ∎ + lemma2 : {c10 : ℕ} → Tautology stmt2Cond whileInv + lemma2 {c10} env = bool-case (stmt2Cond env) ( + λ eq → let open ≡-Reasoning in + begin + (stmt2Cond env) ⇒ (whileInv env) + ≡⟨⟩ + (stmt2Cond env) ⇒ ( Equal (varn env + vari env) c10 ) + ≡⟨ cong ( \ x -> (stmt2Cond {c10} env) ⇒ ( Equal x c10 ) ) ( lemma23 {env} eq ) ⟩ + (stmt2Cond env) ⇒ (Equal c10 c10) + ≡⟨ cong ( \ x -> (stmt2Cond {c10} env) ⇒ x ) (≡→Equal refl ) ⟩ + (stmt2Cond {c10} env) ⇒ true + ≡⟨ ⇒t ⟩ + true + ∎ + ) ( + λ ne → let open ≡-Reasoning in + begin + (stmt2Cond env) ⇒ (whileInv env) + ≡⟨ cong ( \ x -> x ⇒ (whileInv env) ) ne ⟩ + false ⇒ (whileInv {c10} env) + ≡⟨ f⇒ {whileInv {c10} env} ⟩ + true + ∎ + ) + lemma3 : Axiom (λ e → whileInv e ∧ lt zero (varn e)) (λ env → record { varn = varn env ; vari = vari env + 1 }) whileInv' + lemma3 env = impl⇒ ( λ cond → let open ≡-Reasoning in + begin + whileInv' (record { varn = varn env ; vari = vari env + 1 }) + ≡⟨⟩ + Equal (varn env + (vari env + 1)) (suc c10) ∧ (lt 0 (varn env) ) + ≡⟨ cong ( λ z → Equal (varn env + (vari env + 1)) (suc c10) ∧ z ) (∧-pi2 cond ) ⟩ + Equal (varn env + (vari env + 1)) (suc c10) ∧ true + ≡⟨ ∧true ⟩ + Equal (varn env + (vari env + 1)) (suc c10) + ≡⟨ cong ( \ x -> Equal x (suc c10) ) (sym (+-assoc (varn env) (vari env) 1)) ⟩ + Equal ((varn env + vari env) + 1) (suc c10) + ≡⟨ cong ( \ x -> Equal x (suc c10) ) +1≡suc ⟩ + Equal (suc (varn env + vari env)) (suc c10) + ≡⟨ sym Equal+1 ⟩ + Equal ((varn env + vari env) ) c10 + ≡⟨ ∧-pi1 cond ⟩ + true + ∎ ) + lemma41 : (env : Env ) → {c10 : ℕ} → (varn env + vari env) ≡ (suc c10) → lt 0 (varn env) ≡ true → Equal ((varn env - 1) + vari env) c10 ≡ true + lemma41 env {c10} c1 c2 = let open ≡-Reasoning in + begin + Equal ((varn env - 1) + vari env) c10 + ≡⟨ cong ( λ z → Equal ((z - 1 ) + vari env ) c10 ) (sym (suc-predℕ=n c2) ) ⟩ + Equal ((suc (predℕ {varn env} c2 ) - 1) + vari env) c10 + ≡⟨⟩ + Equal ((predℕ {varn env} c2 ) + vari env) c10 + ≡⟨ Equal+1 ⟩ + Equal ((suc (predℕ {varn env} c2 )) + vari env) (suc c10) + ≡⟨ cong ( λ z → Equal (z + vari env ) (suc c10) ) (suc-predℕ=n c2 ) ⟩ + Equal (varn env + vari env) (suc c10) + ≡⟨ cong ( λ z → (Equal z (suc c10) )) c1 ⟩ + Equal (suc c10) (suc c10) + ≡⟨ ≡→Equal refl ⟩ + true + ∎ + lemma4 : {c10 : ℕ} → Axiom whileInv' (λ env → record { varn = varn env - 1 ; vari = vari env }) whileInv + lemma4 {c10} env = impl⇒ ( λ cond → let open ≡-Reasoning in + begin + whileInv (record { varn = varn env - 1 ; vari = vari env }) + ≡⟨⟩ + Equal ((varn env - 1) + vari env) c10 + ≡⟨ lemma41 env (Equal→≡ (∧-pi1 cond)) (∧-pi2 cond) ⟩ + true + ∎ + ) + lemma51 : (z : Env ) → neg (λ z → lt zero (varn z)) z ≡ true → varn z ≡ zero + lemma51 z cond with varn z + lemma51 z refl | zero = refl + lemma51 z () | suc x + lemma5 : {c10 : ℕ} → Tautology ((λ e → Equal (varn e + vari e) c10) and (neg (λ z → lt zero (varn z)))) termCond + lemma5 {c10} env = impl⇒ ( λ cond → let open ≡-Reasoning in + begin + termCond env + ≡⟨⟩ + Equal (vari env) c10 + ≡⟨⟩ + Equal (zero + vari env) c10 + ≡⟨ cong ( λ z → Equal (z + vari env) c10 ) (sym ( lemma51 env ( ∧-pi2 cond ) )) ⟩ + Equal (varn env + vari env) c10 + ≡⟨ ∧-pi1 cond ⟩ + true + ∎ + ) + +--- necessary definitions for Hoare.agda ( Soundness ) + +State : Set +State = Env + +open import RelOp +module RelOpState = RelOp State + +open import Data.Product +open import Relation.Binary + +NotP : {S : Set} -> Pred S -> Pred S +NotP X s = ¬ X s + +_/\_ : Cond -> Cond -> Cond +b1 /\ b2 = b1 and b2 + +_\/_ : Cond -> Cond -> Cond +b1 \/ b2 = neg (neg b1 /\ neg b2) + +SemCond : Cond -> State -> Set +SemCond c p = c p ≡ true + +tautValid : (b1 b2 : Cond) -> Tautology b1 b2 -> + (s : State) -> SemCond b1 s -> SemCond b2 s +tautValid b1 b2 taut s cond with b1 s | b2 s | taut s +tautValid b1 b2 taut s () | false | false | refl +tautValid b1 b2 taut s _ | false | true | refl = refl +tautValid b1 b2 taut s _ | true | false | () +tautValid b1 b2 taut s _ | true | true | refl = refl + +respNeg : (b : Cond) -> (s : State) -> + Iff (SemCond (neg b) s) (¬ SemCond b s) +respNeg b s = ( left , right ) where + left : not (b s) ≡ true → (b s) ≡ true → ⊥ + left ne with b s + left refl | false = λ () + left () | true + right : ((b s) ≡ true → ⊥) → not (b s) ≡ true + right ne with b s + right ne | false = refl + right ne | true = ⊥-elim ( ne refl ) + +respAnd : (b1 b2 : Cond) -> (s : State) -> + Iff (SemCond (b1 /\ b2) s) + ((SemCond b1 s) × (SemCond b2 s)) +respAnd b1 b2 s = ( left , right ) where + left : b1 s ∧ b2 s ≡ true → (b1 s ≡ true) × (b2 s ≡ true) + left and with b1 s | b2 s + left () | false | false + left () | false | true + left () | true | false + left refl | true | true = ( refl , refl ) + right : (b1 s ≡ true) × (b2 s ≡ true) → b1 s ∧ b2 s ≡ true + right ( x1 , x2 ) with b1 s | b2 s + right (() , ()) | false | false + right (() , _) | false | true + right (_ , ()) | true | false + right (refl , refl) | true | true = refl + +PrimSemComm : ∀ {l} -> PrimComm -> Rel State l +PrimSemComm prim s1 s2 = Id State (prim s1) s2 + + + +axiomValid : ∀ {l} -> (bPre : Cond) -> (pcm : PrimComm) -> (bPost : Cond) -> + (ax : Axiom bPre pcm bPost) -> (s1 s2 : State) -> + SemCond bPre s1 -> PrimSemComm {l} pcm s1 s2 -> SemCond bPost s2 +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) semPre ref with bPre s1 | bPost (pcm s1) | ax s1 +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) () ref | false | false | refl +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) semPre ref | false | true | refl = refl +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) semPre ref | true | false | () +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) semPre ref | true | true | refl = refl + +open import HoareSoundness + Cond + PrimComm + neg + _and_ + Tautology + State + SemCond + tautValid + respNeg + respAnd + PrimSemComm + Axiom + axiomValid + +PrimSoundness : {bPre : Cond} -> {cm : Comm} -> {bPost : Cond} -> + HTProof bPre cm bPost -> Satisfies bPre cm bPost +PrimSoundness {bPre} {cm} {bPost} ht = Soundness ht + + +proofOfProgram : (c10 : ℕ) → (input output : Env ) + → initCond input ≡ true + → (SemComm (program c10) input output) + → termCond {c10} output ≡ true +proofOfProgram c10 input output ic sem = PrimSoundness (proof1 c10) input output ic sem
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestPrimProof.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,288 @@ +module whileTestPrimProof where + +open import Function +open import Data.Nat +open import Data.Bool hiding ( _@$\stackrel{?}{=}$@_ ) +open import Level renaming ( suc to succ ; zero to Zero ) +open import Relation.Nullary using (@$\neg$@_; Dec; yes; no) +open import Relation.Binary.PropositionalEquality + +open import utilities hiding ( _@$\wedge$@_ ) +open import whileTestPrim + +open import Hoare PrimComm Cond Axiom Tautology _and_ neg + +open Env + +initCond : Cond +initCond env = true + +stmt1Cond : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Cond +stmt1Cond {c10} env = Equal (varn env) c10 + +init-case : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ (env : Env) @$\rightarrow$@ (( @$\lambda$@ e @$\rightarrow$@ true @$\Rightarrow$@ stmt1Cond {c10} e ) (record { varn = c10 ; vari = vari env }) ) @$\equiv$@ true +init-case {c10} _ = impl@$\Rightarrow$@ ( @$\lambda$@ cond @$\rightarrow$@ @$\equiv$@@$\rightarrow$@Equal refl ) + +init-type : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Axiom (@$\lambda$@ env @$\rightarrow$@ true) (@$\lambda$@ env @$\rightarrow$@ record { varn = c10 ; vari = vari env }) (stmt1Cond {c10}) +init-type {c10} env = init-case env + +stmt2Cond : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Cond +stmt2Cond {c10} env = (Equal (varn env) c10) @$\wedge$@ (Equal (vari env) 0) + +lemma1 : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Axiom (stmt1Cond {c10}) (@$\lambda$@ env @$\rightarrow$@ record { varn = varn env ; vari = 0 }) (stmt2Cond {c10}) +lemma1 {c10} env = impl@$\Rightarrow$@ ( @$\lambda$@ cond @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + (Equal (varn env) c10 ) @$\wedge$@ true + @$\equiv$@@$\langle$@ @$\wedge$@true @$\rangle$@ + Equal (varn env) c10 + @$\equiv$@@$\langle$@ cond @$\rangle$@ + true + @$\blacksquare$@ ) + +-- simple : @$\mathbb{N}$@ @$\rightarrow$@ Comm +-- simple c10 = +-- Seq ( PComm (@$\lambda$@ env @$\rightarrow$@ record env {varn = c10})) +-- $ PComm (@$\lambda$@ env @$\rightarrow$@ record env {vari = 0}) + +proofs : (c10 : @$\mathbb{N}$@) @$\rightarrow$@ HTProof initCond (simple c10) (stmt2Cond {c10}) +proofs c10 = + SeqRule {initCond} ( PrimRule (init-case {c10} )) + $ PrimRule {stmt1Cond} {_} {stmt2Cond} (lemma1 {c10}) + +open import Data.Empty + +open import Data.Nat.Properties + +whileInv : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Cond +whileInv {c10} env = Equal ((varn env) + (vari env)) c10 + +whileInv' : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Cond +whileInv'{c10} env = Equal ((varn env) + (vari env)) (suc c10) @$\wedge$@ lt zero (varn env) + +termCond : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Cond +termCond {c10} env = Equal (vari env) c10 + + +-- program : @$\mathbb{N}$@ @$\rightarrow$@ Comm +-- program c10 = +-- Seq ( PComm (@$\lambda$@ env @$\rightarrow$@ record env {varn = c10})) +-- $ Seq ( PComm (@$\lambda$@ env @$\rightarrow$@ record env {vari = 0})) +-- $ While (@$\lambda$@ env @$\rightarrow$@ lt zero (varn env ) ) +-- (Seq (PComm (@$\lambda$@ env @$\rightarrow$@ record env {vari = ((vari env) + 1)} )) +-- $ PComm (@$\lambda$@ env @$\rightarrow$@ record env {varn = ((varn env) - 1)} )) + + +proof1 : (c10 : @$\mathbb{N}$@) @$\rightarrow$@ HTProof initCond (program c10 ) (termCond {c10}) +proof1 c10 = + SeqRule {@$\lambda$@ e @$\rightarrow$@ true} ( PrimRule (init-case {c10} )) + $ SeqRule {@$\lambda$@ e @$\rightarrow$@ Equal (varn e) c10} ( PrimRule lemma1 ) + $ WeakeningRule {@$\lambda$@ e @$\rightarrow$@ (Equal (varn e) c10) @$\wedge$@ (Equal (vari e) 0)} lemma2 ( + WhileRule {_} {@$\lambda$@ e @$\rightarrow$@ Equal ((varn e) + (vari e)) c10} + $ SeqRule (PrimRule {@$\lambda$@ e @$\rightarrow$@ whileInv e @$\wedge$@ lt zero (varn e) } lemma3 ) + $ PrimRule {whileInv'} {_} {whileInv} lemma4 ) lemma5 + where + lemma21 : {env : Env } @$\rightarrow$@ {c10 : @$\mathbb{N}$@} @$\rightarrow$@ stmt2Cond env @$\equiv$@ true @$\rightarrow$@ varn env @$\equiv$@ c10 + lemma21 eq = Equal@$\rightarrow$@@$\equiv$@ (@$\wedge$@-pi1 eq) + lemma22 : {env : Env } @$\rightarrow$@ {c10 : @$\mathbb{N}$@} @$\rightarrow$@ stmt2Cond {c10} env @$\equiv$@ true @$\rightarrow$@ vari env @$\equiv$@ 0 + lemma22 eq = Equal@$\rightarrow$@@$\equiv$@ (@$\wedge$@-pi2 eq) + lemma23 : {env : Env } @$\rightarrow$@ {c10 : @$\mathbb{N}$@} @$\rightarrow$@ stmt2Cond env @$\equiv$@ true @$\rightarrow$@ varn env + vari env @$\equiv$@ c10 + lemma23 {env} {c10} eq = let open @$\equiv$@-Reasoning in + begin + varn env + vari env + @$\equiv$@@$\langle$@ cong ( \ x @$\rightarrow$@ x + vari env ) (lemma21 eq ) @$\rangle$@ + c10 + vari env + @$\equiv$@@$\langle$@ cong ( \ x @$\rightarrow$@ c10 + x) (lemma22 {env} {c10} eq ) @$\rangle$@ + c10 + 0 + @$\equiv$@@$\langle$@ +-sym {c10} {0} @$\rangle$@ + 0 + c10 + @$\equiv$@@$\langle$@@$\rangle$@ + c10 + @$\blacksquare$@ + lemma2 : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Tautology stmt2Cond whileInv + lemma2 {c10} env = bool-case (stmt2Cond env) ( + @$\lambda$@ eq @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + (stmt2Cond env) @$\Rightarrow$@ (whileInv env) + @$\equiv$@@$\langle$@@$\rangle$@ + (stmt2Cond env) @$\Rightarrow$@ ( Equal (varn env + vari env) c10 ) + @$\equiv$@@$\langle$@ cong ( \ x @$\rightarrow$@ (stmt2Cond {c10} env) @$\Rightarrow$@ ( Equal x c10 ) ) ( lemma23 {env} eq ) @$\rangle$@ + (stmt2Cond env) @$\Rightarrow$@ (Equal c10 c10) + @$\equiv$@@$\langle$@ cong ( \ x @$\rightarrow$@ (stmt2Cond {c10} env) @$\Rightarrow$@ x ) (@$\equiv$@@$\rightarrow$@Equal refl ) @$\rangle$@ + (stmt2Cond {c10} env) @$\Rightarrow$@ true + @$\equiv$@@$\langle$@ @$\Rightarrow$@t @$\rangle$@ + true + @$\blacksquare$@ + ) ( + @$\lambda$@ ne @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + (stmt2Cond env) @$\Rightarrow$@ (whileInv env) + @$\equiv$@@$\langle$@ cong ( \ x @$\rightarrow$@ x @$\Rightarrow$@ (whileInv env) ) ne @$\rangle$@ + false @$\Rightarrow$@ (whileInv {c10} env) + @$\equiv$@@$\langle$@ f@$\Rightarrow$@ {whileInv {c10} env} @$\rangle$@ + true + @$\blacksquare$@ + ) + lemma3 : Axiom (@$\lambda$@ e @$\rightarrow$@ whileInv e @$\wedge$@ lt zero (varn e)) (@$\lambda$@ env @$\rightarrow$@ record { varn = varn env ; vari = vari env + 1 }) whileInv' + lemma3 env = impl@$\Rightarrow$@ ( @$\lambda$@ cond @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + whileInv' (record { varn = varn env ; vari = vari env + 1 }) + @$\equiv$@@$\langle$@@$\rangle$@ + Equal (varn env + (vari env + 1)) (suc c10) @$\wedge$@ (lt 0 (varn env) ) + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ Equal (varn env + (vari env + 1)) (suc c10) @$\wedge$@ z ) (@$\wedge$@-pi2 cond ) @$\rangle$@ + Equal (varn env + (vari env + 1)) (suc c10) @$\wedge$@ true + @$\equiv$@@$\langle$@ @$\wedge$@true @$\rangle$@ + Equal (varn env + (vari env + 1)) (suc c10) + @$\equiv$@@$\langle$@ cong ( \ x @$\rightarrow$@ Equal x (suc c10) ) (sym (+-assoc (varn env) (vari env) 1)) @$\rangle$@ + Equal ((varn env + vari env) + 1) (suc c10) + @$\equiv$@@$\langle$@ cong ( \ x @$\rightarrow$@ Equal x (suc c10) ) +1@$\equiv$@suc @$\rangle$@ + Equal (suc (varn env + vari env)) (suc c10) + @$\equiv$@@$\langle$@ sym Equal+1 @$\rangle$@ + Equal ((varn env + vari env) ) c10 + @$\equiv$@@$\langle$@ @$\wedge$@-pi1 cond @$\rangle$@ + true + @$\blacksquare$@ ) + lemma41 : (env : Env ) @$\rightarrow$@ {c10 : @$\mathbb{N}$@} @$\rightarrow$@ (varn env + vari env) @$\equiv$@ (suc c10) @$\rightarrow$@ lt 0 (varn env) @$\equiv$@ true @$\rightarrow$@ Equal ((varn env - 1) + vari env) c10 @$\equiv$@ true + lemma41 env {c10} c1 c2 = let open @$\equiv$@-Reasoning in + begin + Equal ((varn env - 1) + vari env) c10 + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ Equal ((z - 1 ) + vari env ) c10 ) (sym (suc-pred@$\mathbb{N}$@=n c2) ) @$\rangle$@ + Equal ((suc (pred@$\mathbb{N}$@ {varn env} c2 ) - 1) + vari env) c10 + @$\equiv$@@$\langle$@@$\rangle$@ + Equal ((pred@$\mathbb{N}$@ {varn env} c2 ) + vari env) c10 + @$\equiv$@@$\langle$@ Equal+1 @$\rangle$@ + Equal ((suc (pred@$\mathbb{N}$@ {varn env} c2 )) + vari env) (suc c10) + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ Equal (z + vari env ) (suc c10) ) (suc-pred@$\mathbb{N}$@=n c2 ) @$\rangle$@ + Equal (varn env + vari env) (suc c10) + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ (Equal z (suc c10) )) c1 @$\rangle$@ + Equal (suc c10) (suc c10) + @$\equiv$@@$\langle$@ @$\equiv$@@$\rightarrow$@Equal refl @$\rangle$@ + true + @$\blacksquare$@ + lemma4 : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Axiom whileInv' (@$\lambda$@ env @$\rightarrow$@ record { varn = varn env - 1 ; vari = vari env }) whileInv + lemma4 {c10} env = impl@$\Rightarrow$@ ( @$\lambda$@ cond @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + whileInv (record { varn = varn env - 1 ; vari = vari env }) + @$\equiv$@@$\langle$@@$\rangle$@ + Equal ((varn env - 1) + vari env) c10 + @$\equiv$@@$\langle$@ lemma41 env (Equal@$\rightarrow$@@$\equiv$@ (@$\wedge$@-pi1 cond)) (@$\wedge$@-pi2 cond) @$\rangle$@ + true + @$\blacksquare$@ + ) + lemma51 : (z : Env ) @$\rightarrow$@ neg (@$\lambda$@ z @$\rightarrow$@ lt zero (varn z)) z @$\equiv$@ true @$\rightarrow$@ varn z @$\equiv$@ zero + lemma51 z cond with varn z + lemma51 z refl | zero = refl + lemma51 z () | suc x + lemma5 : {c10 : @$\mathbb{N}$@} @$\rightarrow$@ Tautology ((@$\lambda$@ e @$\rightarrow$@ Equal (varn e + vari e) c10) and (neg (@$\lambda$@ z @$\rightarrow$@ lt zero (varn z)))) termCond + lemma5 {c10} env = impl@$\Rightarrow$@ ( @$\lambda$@ cond @$\rightarrow$@ let open @$\equiv$@-Reasoning in + begin + termCond env + @$\equiv$@@$\langle$@@$\rangle$@ + Equal (vari env) c10 + @$\equiv$@@$\langle$@@$\rangle$@ + Equal (zero + vari env) c10 + @$\equiv$@@$\langle$@ cong ( @$\lambda$@ z @$\rightarrow$@ Equal (z + vari env) c10 ) (sym ( lemma51 env ( @$\wedge$@-pi2 cond ) )) @$\rangle$@ + Equal (varn env + vari env) c10 + @$\equiv$@@$\langle$@ @$\wedge$@-pi1 cond @$\rangle$@ + true + @$\blacksquare$@ + ) + +--- necessary definitions for Hoare.agda ( Soundness ) + +State : Set +State = Env + +open import RelOp +module RelOpState = RelOp State + +open import Data.Product +open import Relation.Binary + +NotP : {S : Set} @$\rightarrow$@ Pred S @$\rightarrow$@ Pred S +NotP X s = @$\neg$@ X s + +_@$\wedge$@_ : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Cond +b1 @$\wedge$@ b2 = b1 and b2 + +_\/_ : Cond @$\rightarrow$@ Cond @$\rightarrow$@ Cond +b1 \/ b2 = neg (neg b1 @$\wedge$@ neg b2) + +SemCond : Cond @$\rightarrow$@ State @$\rightarrow$@ Set +SemCond c p = c p @$\equiv$@ true + +tautValid : (b1 b2 : Cond) @$\rightarrow$@ Tautology b1 b2 @$\rightarrow$@ + (s : State) @$\rightarrow$@ SemCond b1 s @$\rightarrow$@ SemCond b2 s +tautValid b1 b2 taut s cond with b1 s | b2 s | taut s +tautValid b1 b2 taut s () | false | false | refl +tautValid b1 b2 taut s _ | false | true | refl = refl +tautValid b1 b2 taut s _ | true | false | () +tautValid b1 b2 taut s _ | true | true | refl = refl + +respNeg : (b : Cond) @$\rightarrow$@ (s : State) @$\rightarrow$@ + Iff (SemCond (neg b) s) (@$\neg$@ SemCond b s) +respNeg b s = ( left , right ) where + left : not (b s) @$\equiv$@ true @$\rightarrow$@ (b s) @$\equiv$@ true @$\rightarrow$@ @$\bot$@ + left ne with b s + left refl | false = @$\lambda$@ () + left () | true + right : ((b s) @$\equiv$@ true @$\rightarrow$@ @$\bot$@) @$\rightarrow$@ not (b s) @$\equiv$@ true + right ne with b s + right ne | false = refl + right ne | true = @$\bot$@-elim ( ne refl ) + +respAnd : (b1 b2 : Cond) @$\rightarrow$@ (s : State) @$\rightarrow$@ + Iff (SemCond (b1 @$\wedge$@ b2) s) + ((SemCond b1 s) @$\times$@ (SemCond b2 s)) +respAnd b1 b2 s = ( left , right ) where + left : b1 s @$\wedge$@ b2 s @$\equiv$@ true @$\rightarrow$@ (b1 s @$\equiv$@ true) @$\times$@ (b2 s @$\equiv$@ true) + left and with b1 s | b2 s + left () | false | false + left () | false | true + left () | true | false + left refl | true | true = ( refl , refl ) + right : (b1 s @$\equiv$@ true) @$\times$@ (b2 s @$\equiv$@ true) @$\rightarrow$@ b1 s @$\wedge$@ b2 s @$\equiv$@ true + right ( x1 , x2 ) with b1 s | b2 s + right (() , ()) | false | false + right (() , _) | false | true + right (_ , ()) | true | false + right (refl , refl) | true | true = refl + +PrimSemComm : @$\forall$@ {l} @$\rightarrow$@ PrimComm @$\rightarrow$@ Rel State l +PrimSemComm prim s1 s2 = Id State (prim s1) s2 + + + +axiomValid : @$\forall$@ {l} @$\rightarrow$@ (bPre : Cond) @$\rightarrow$@ (pcm : PrimComm) @$\rightarrow$@ (bPost : Cond) @$\rightarrow$@ + (ax : Axiom bPre pcm bPost) @$\rightarrow$@ (s1 s2 : State) @$\rightarrow$@ + SemCond bPre s1 @$\rightarrow$@ PrimSemComm {l} pcm s1 s2 @$\rightarrow$@ SemCond bPost s2 +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) semPre ref with bPre s1 | bPost (pcm s1) | ax s1 +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) () ref | false | false | refl +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) semPre ref | false | true | refl = refl +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) semPre ref | true | false | () +axiomValid {l} bPre pcm bPost ax s1 .(pcm s1) semPre ref | true | true | refl = refl + +open import HoareSoundness + Cond + PrimComm + neg + _and_ + Tautology + State + SemCond + tautValid + respNeg + respAnd + PrimSemComm + Axiom + axiomValid + +PrimSoundness : {bPre : Cond} @$\rightarrow$@ {cm : Comm} @$\rightarrow$@ {bPost : Cond} @$\rightarrow$@ + HTProof bPre cm bPost @$\rightarrow$@ Satisfies bPre cm bPost +PrimSoundness {bPre} {cm} {bPost} ht = Soundness ht + + +proofOfProgram : (c10 : @$\mathbb{N}$@) @$\rightarrow$@ (input output : Env ) + @$\rightarrow$@ initCond input @$\equiv$@ true + @$\rightarrow$@ (SemComm (program c10) input output) + @$\rightarrow$@ termCond {c10} output @$\equiv$@ true +proofOfProgram c10 input output ic sem = PrimSoundness (proof1 c10) input output ic sem
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestProof.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,65 @@ +module whileTestProof where +-- +-- Using imply relation to make soundness explicit +-- termination is shown by induction on varn +-- + +data _implies_ (A B : Set ) : Set (succ Zero) where + proof : ( A → B ) → A implies B + +implies2p : {A B : Set } → A implies B → A → B +implies2p (proof x) = x + +whileTestPSem : (c : ℕ) → whileTestP c ( λ env → ⊤ implies (whileTestStateP s1 env) ) +whileTestPSem c = proof ( λ _ → record { pi1 = refl ; pi2 = refl } ) + +SemGears : (f : {l : Level } {t : Set l } → (e0 : Envc ) → ((e : Envc) → t) → t ) → Set (succ Zero) +SemGears f = Envc → Envc → Set + +GearsUnitSound : (e0 e1 : Envc) {pre : Envc → Set} {post : Envc → Set} + → (f : {l : Level } {t : Set l } → (e0 : Envc ) → (Envc → t) → t ) + → (fsem : (e0 : Envc ) → f e0 ( λ e1 → (pre e0) implies (post e1))) + → f e0 (λ e1 → pre e0 implies post e1) +GearsUnitSound e0 e1 f fsem = fsem e0 + +whileTestPSemSound : (c : ℕ ) (output : Envc ) → output ≡ whileTestP c (λ e → e) → ⊤ implies ((vari output ≡ 0) /\ (varn output ≡ c)) +whileTestPSemSound c output refl = proof (λ x → record { pi1 = refl ; pi2 = refl }) +-- whileTestPSem c + + +whileConvPSemSound : {l : Level} → (input : Envc) → (whileTestStateP s1 input ) implies (whileTestStateP s2 input) +whileConvPSemSound input = proof λ x → (conv input x) where + conv : (env : Envc ) → (vari env ≡ 0) /\ (varn env ≡ c10 env) → varn env + vari env ≡ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero + +loopPP : (n : ℕ) → (input : Envc ) → (n ≡ varn input) → Envc +loopPP zero input refl = input +loopPP (suc n) input refl = + loopPP n (record input { varn = pred (varn input) ; vari = suc (vari input)}) refl + +whileLoopPSem : {l : Level} {t : Set l} → (input : Envc ) → whileTestStateP s2 input + → (next : (output : Envc ) → (whileTestStateP s2 input ) implies (whileTestStateP s2 output) → t) + → (exit : (output : Envc ) → (whileTestStateP s2 input ) implies (whileTestStateP sf output) → t) → t +whileLoopPSem env s next exit with varn env | s +... | zero | _ = exit env (proof (λ z → z)) +... | (suc varn ) | refl = next ( record env { varn = varn ; vari = suc (vari env) } ) (proof λ x → +-suc varn (vari env) ) + +loopPPSem : (input output : Envc ) → output ≡ loopPP (varn input) input refl + → (whileTestStateP s2 input ) → (whileTestStateP s2 input ) implies (whileTestStateP sf output) +loopPPSem input output refl s2p = loopPPSemInduct (varn input) input refl refl s2p + where + lem : (n : ℕ) → (env : Envc) → n + suc (vari env) ≡ suc (n + vari env) + lem n env = +-suc (n) (vari env) + loopPPSemInduct : (n : ℕ) → (current : Envc) → (eq : n ≡ varn current) → (loopeq : output ≡ loopPP n current eq) + → (whileTestStateP s2 current ) → (whileTestStateP s2 current ) implies (whileTestStateP sf output) + loopPPSemInduct zero current refl loopeq refl rewrite loopeq = proof (λ x → refl) + loopPPSemInduct (suc n) current refl loopeq refl rewrite (sym (lem n current)) = + whileLoopPSem current refl + (λ output x → loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + (λ output x → loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + +whileLoopPSemSound : {l : Level} → (input output : Envc ) + → whileTestStateP s2 input + → output ≡ loopPP (varn input) input refl + → (whileTestStateP s2 input ) implies ( whileTestStateP sf output ) +whileLoopPSemSound {l} input output pre eq = loopPPSem input output eq pre
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestProof.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,65 @@ +module whileTestProof where +-- +-- Using imply relation to make soundness explicit +-- termination is shown by induction on varn +-- + +data _implies_ (A B : Set ) : Set (succ Zero) where + proof : ( A @$\rightarrow$@ B ) @$\rightarrow$@ A implies B + +implies2p : {A B : Set } @$\rightarrow$@ A implies B @$\rightarrow$@ A @$\rightarrow$@ B +implies2p (proof x) = x + +whileTestPSem : (c : @$\mathbb{N}$@) @$\rightarrow$@ whileTestP c ( @$\lambda$@ env @$\rightarrow$@ ⊤ implies (whileTestStateP s1 env) ) +whileTestPSem c = proof ( @$\lambda$@ _ @$\rightarrow$@ record { pi1 = refl ; pi2 = refl } ) + +SemGears : (f : {l : Level } {t : Set l } @$\rightarrow$@ (e0 : Envc ) @$\rightarrow$@ ((e : Envc) @$\rightarrow$@ t) @$\rightarrow$@ t ) @$\rightarrow$@ Set (succ Zero) +SemGears f = Envc @$\rightarrow$@ Envc @$\rightarrow$@ Set + +GearsUnitSound : (e0 e1 : Envc) {pre : Envc @$\rightarrow$@ Set} {post : Envc @$\rightarrow$@ Set} + @$\rightarrow$@ (f : {l : Level } {t : Set l } @$\rightarrow$@ (e0 : Envc ) @$\rightarrow$@ (Envc @$\rightarrow$@ t) @$\rightarrow$@ t ) + @$\rightarrow$@ (fsem : (e0 : Envc ) @$\rightarrow$@ f e0 ( @$\lambda$@ e1 @$\rightarrow$@ (pre e0) implies (post e1))) + @$\rightarrow$@ f e0 (@$\lambda$@ e1 @$\rightarrow$@ pre e0 implies post e1) +GearsUnitSound e0 e1 f fsem = fsem e0 + +whileTestPSemSound : (c : @$\mathbb{N}$@ ) (output : Envc ) @$\rightarrow$@ output @$\equiv$@ whileTestP c (@$\lambda$@ e @$\rightarrow$@ e) @$\rightarrow$@ ⊤ implies ((vari output @$\equiv$@ 0) @$\wedge$@ (varn output @$\equiv$@ c)) +whileTestPSemSound c output refl = proof (@$\lambda$@ x @$\rightarrow$@ record { pi1 = refl ; pi2 = refl }) +-- whileTestPSem c + + +whileConvPSemSound : {l : Level} @$\rightarrow$@ (input : Envc) @$\rightarrow$@ (whileTestStateP s1 input ) implies (whileTestStateP s2 input) +whileConvPSemSound input = proof @$\lambda$@ x @$\rightarrow$@ (conv input x) where + conv : (env : Envc ) @$\rightarrow$@ (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env) @$\rightarrow$@ varn env + vari env @$\equiv$@ c10 env + conv e record { pi1 = refl ; pi2 = refl } = +zero + +loopPP : (n : @$\mathbb{N}$@) @$\rightarrow$@ (input : Envc ) @$\rightarrow$@ (n @$\equiv$@ varn input) @$\rightarrow$@ Envc +loopPP zero input refl = input +loopPP (suc n) input refl = + loopPP n (record input { varn = pred (varn input) ; vari = suc (vari input)}) refl + +whileLoopPSem : {l : Level} {t : Set l} @$\rightarrow$@ (input : Envc ) @$\rightarrow$@ whileTestStateP s2 input + @$\rightarrow$@ (next : (output : Envc ) @$\rightarrow$@ (whileTestStateP s2 input ) implies (whileTestStateP s2 output) @$\rightarrow$@ t) + @$\rightarrow$@ (exit : (output : Envc ) @$\rightarrow$@ (whileTestStateP s2 input ) implies (whileTestStateP sf output) @$\rightarrow$@ t) @$\rightarrow$@ t +whileLoopPSem env s next exit with varn env | s +... | zero | _ = exit env (proof (@$\lambda$@ z @$\rightarrow$@ z)) +... | (suc varn ) | refl = next ( record env { varn = varn ; vari = suc (vari env) } ) (proof @$\lambda$@ x @$\rightarrow$@ +-suc varn (vari env) ) + +loopPPSem : (input output : Envc ) @$\rightarrow$@ output @$\equiv$@ loopPP (varn input) input refl + @$\rightarrow$@ (whileTestStateP s2 input ) @$\rightarrow$@ (whileTestStateP s2 input ) implies (whileTestStateP sf output) +loopPPSem input output refl s2p = loopPPSemInduct (varn input) input refl refl s2p + where + lem : (n : @$\mathbb{N}$@) @$\rightarrow$@ (env : Envc) @$\rightarrow$@ n + suc (vari env) @$\equiv$@ suc (n + vari env) + lem n env = +-suc (n) (vari env) + loopPPSemInduct : (n : @$\mathbb{N}$@) @$\rightarrow$@ (current : Envc) @$\rightarrow$@ (eq : n @$\equiv$@ varn current) @$\rightarrow$@ (loopeq : output @$\equiv$@ loopPP n current eq) + @$\rightarrow$@ (whileTestStateP s2 current ) @$\rightarrow$@ (whileTestStateP s2 current ) implies (whileTestStateP sf output) + loopPPSemInduct zero current refl loopeq refl rewrite loopeq = proof (@$\lambda$@ x @$\rightarrow$@ refl) + loopPPSemInduct (suc n) current refl loopeq refl rewrite (sym (lem n current)) = + whileLoopPSem current refl + (@$\lambda$@ output x @$\rightarrow$@ loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + (@$\lambda$@ output x @$\rightarrow$@ loopPPSemInduct n (record { c10 = n + suc (vari current) ; varn = n ; vari = suc (vari current) }) refl loopeq refl) + +whileLoopPSemSound : {l : Level} @$\rightarrow$@ (input output : Envc ) + @$\rightarrow$@ whileTestStateP s2 input + @$\rightarrow$@ output @$\equiv$@ loopPP (varn input) input refl + @$\rightarrow$@ (whileTestStateP s2 input ) implies ( whileTestStateP sf output ) +whileLoopPSemSound {l} input output pre eq = loopPPSem input output eq pre
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestSemSound.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +whileTestPSemSound : (c : ℕ ) (output : Envc ) + → output ≡ whileTestP c (λ e → e) + → ⊤ implies ((vari output ≡ 0) ∧ (varn output ≡ c)) + whileTestPSemSound c output refl = proof (λ _ → record { pi1 = refl ; pi2 = refl })
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/whileTestSemSound.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,4 @@ +whileTestPSemSound : (c : @$\mathbb{N}$@ ) (output : Envc ) + @$\rightarrow$@ output @$\equiv$@ whileTestP c (@$\lambda$@ e @$\rightarrow$@ e) + @$\rightarrow$@ @$\top$@ implies ((vari output @$\equiv$@ 0) @$\wedge$@ (varn output @$\equiv$@ c)) + whileTestPSemSound c output refl = proof (@$\lambda$@ _ @$\rightarrow$@ record { pi1 = refl ; pi2 = refl })
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/workerRun.cbc Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +__code getTaskCPUWorker(struct CPUWorker* cpuWorker, struct Context* task, struct Worker* worker) { + if (!task) { + goto worker->shutdown(); // end thread + } + task->worker = worker; + enum Code taskCg = task->next; + task->next = C_odgCommitCPUWorker; // commit outputDG after task exec + goto meta(task, taskCg); // switch task context +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/zero.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ ++zero : { y : ℕ } → y + zero ≡ y ++zero {zero} = refl ++zero {suc y} = cong suc ( +zero {y} ) + +-- cong : ∀ (f : A → B) {x y} → x ≡ y → f x ≡ f y +-- cong f refl = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/src/zero.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,6 @@ ++zero : { y : @$\mathbb{N}$@ } @$\rightarrow$@ y + zero @$\equiv$@ y ++zero {zero} = refl ++zero {suc y} = cong suc ( +zero {y} ) + +-- cong : @$\forall$@ (f : A @$\rightarrow$@ B) {x y} @$\rightarrow$@ x @$\equiv$@ y @$\rightarrow$@ f x @$\equiv$@ f y +-- cong f refl = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/.#cbc.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +soto@Szeleta.local.353 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/.#cbc_agda.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +soto@Szeleta.local.353 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/.#rbt_intro.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +soto@Szeleta.local.353 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/.#rbt_verif.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,1 @@ +soto@Szeleta.local.353 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/abstract.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +\renewcommand{\abstractname}{\normalsize 要 旨} +\begin{abstract} + 当研究室にて Continuation based C\cite{cbc-gcc} (以下CbC) なるC言語の下位言語に当たる言語を開発している。 + 先行研究\cite{ryokka-master}にて Floyd-Hoare Logic\cite{hoare}(以下Hoare Logic)を用いてその検証を行なった。 + 本稿では、先行研究にて実施されなかった CbC における RedBlackTree の検証を Hoare Logic を用いて検証することを目指す。 +\end{abstract} + +\renewcommand{\abstractname}{\normalsize Abstract} +\begin{abstract} + We are developing a language called Continuation based C\cite{cbc-gcc} (CbC), which is a lower language of the C. + In a previous study\cite{ryokka-master} , Floyd-Hoare Logic\cite{hoare} (Hoare Logic) was used to validate it. + In this paper, we aim to use Hoare Logic to validate the red-black tree in CbC, which was not performed in previous studies. +\end{abstract} + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/abstract/abstract.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +\begin{abstract} + 当研究室にて Continuation based C (以下CbC) なるC言語の下位言語に当たる言語を開発している。 + 外間による先行研究にて Floyd-Hoare Logic(以下Hoare Logic)を用いてその検証を行なった。 + 本稿では、先行研究にて実施されなかった CbC における赤黒木の検証を Hoare Logic を用いて検証することを目指す。 + \\ \\ + We are developing a language called Continuation based C (CbC), which is a Subordinate language of the C. + M.Eng Hokama verified it by using Floyd-Hoare Logic (Hoare Logic) in a previous study. + In this paper, we aim to use Hoare Logic to validate the red-black tree in CbC, which was not performed in previous studies. +\end{abstract}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/agda.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,125 @@ +\chapter{定理証明支援系言語 Agda} + + +%\section{Agda} + +Agda とは定理証明支援器であり、関数型言語である。Agda は依存型という型システ +ムを持ち、型を第一級オブジェクトとして扱うことが可能である。また、型システムは +Curry-Howard 同型対応により命題と型付きラムダ計算が一対一で対応するため Agda で +は記述したプログラムを証明することができる。 + +\section{Agdaの基本} + +\subsection{関数の実装} +本節ではAgdaの基本事項について \coderef{plus} を例として解説する。 + +基本事項として、$ \mathbb{N} $ というのは自然数 (Natulal Number) のことである。 +また - (ハイフン) が2つ連続して並んでいる部分はコメントアウトであり、 +ここでは関数を実行した際の例を記述している。 +したがって、これは2つの自然数を受け取って足す関数であることが推測できる。 + +\lstinputlisting[label=plus, caption=plusの実装] {src/agda/plus.agda} + +この関数の定義部分の説明をする。コードの1行目に : (セミコロン)がある。 +この : の前が関数名になり、その後ろがその関数の定義となる。 +: 以降の (x y : $ \mathbb{N} $) は関数は x, y の自然数2つを受けとるという意味になる。 +$ \rightarrow $ 以降は関数が返す型を記述している。 +まとめると、この関数 plus は、型が自然数である2つの変数が x, y を受け取り、 +自然数を返すという定義になる。 + +関数の定義をしたコードの直下で実装を行うのが常である。 +関数名を記述した後に引数を記述して受け取り、= (イコール) 以降で +引数に対応した実装をする。 + +今回の場合 plus x zero であれば +0 である為、そのまま x を返す。 +実装2行目の方で受け取った y の値を減らし、x の値を増やして再び plus の関数に +遷移している。 +受け取った y を +1 されていたとして y の値を減らしている。 + +関数の実装全体をまとめると、x と y の値を足す為に y から x に数値を1つずつ渡す。 +y が 0 になった際に計算が終了となっている。 +指折りでの足し算を実装していると捉えても良い。 + +\subsection{三項演算子の実装} +\_ (アンダースコア) を用いることで入力を受け取る事ができる。 +これを用いることで、三項演算子を実装することができる。 +以下に、三項演算子を使用した \coderef{plus} と同義の関数の例を +以下 \coderef{plus2} 挙げる。 + +\lstinputlisting[label=plus2, caption=三項演算子を用いたplusの実装, firstline=5] {src/agda/plus2.agda} + +利点としては、直感的な記号論理の記述ができる。 +以下、記号論理は基本的に三項演算子を使用して記述する。 + +\subsection{Agdaにおけるラムダ計算} +\lambda + +\subsection{Data 型の実装} +Deta 型とは分岐のことである。 +そのため、それぞれの動作について実装する必要がある。 +例として既出で Data 型である $ \mathbb{N} $ の実装を \coderef{Nat} に示す。 + +\lstinputlisting[label=Nat, caption=Nat] {src/agda/Nat.agda} + +実装から、$ \mathbb{N} $ という型は zero と suc の2つのコンストラクタを持っていることが分かる。 +それぞれの仕様を見てみると、zeroは $ \mathbb{N} $ のみであるが、 +suc は (n : $ \mathbb{N} $ ) $ \rightarrow \ \mathbb{N} $ である。 +つまり、suc 自体の型は $ \mathbb{N} $ であるが、そこから $ \mathbb{N} $ に遷移するということである。 +そのため、suc からは suc か zero に遷移する必要があり、また zero に遷移することで停止する。 +したがって、数値は zero に遷移するまでの suc が遷移した数によって決定される。 + +Data型にはそれぞれの動作について実装する必要があると述べたが、 +言い換えればパターンマッチをする必要があると言える。 +これは puls 関数で suc 同士の場合と、zeroが含まれる場合の両方を実装していることの説明となる。 + +\subsection{パターンマッチ} + +\subsection{Record 型の実装} +Record 型とはオブジェクトあるいは構造体ののようなものである。 +\coderef{And}は AND の関数となる。p1で前方部分が取得でき、p2で後方部分が取得できる。 + +\lstinputlisting[label=And, caption=And] {src/agda/And.agda} + +また、Agda の関数定義では\_(アンダースコア)で囲むことで三項演算子を定義することができる。 + +これを使用して三段論法を定義することができる。 +定義は「AならばB」かつ「BならばC」なら「AならばC」となる。 +\coderef{syllogism}を以下に示す。 + +\lstinputlisting[label=syllogism, caption=syllogism] {src/agda/syllogism.agda} + +コードの解説をすると、引数として x と a が関数に与えられている。 +引数 x の中身は ((A $ \rightarrow $ B) ∧ (B $ \rightarrow $ C)) 、引数 a の中身 +は A である。したがって、(\_∧\_.p1 x a) で (A $ \rightarrow $ B) に A を与えて B を取得し、 +\_∧\_.p2 x で (B $ \rightarrow $ C) であるため、これに B を与えると C が取得できる。 +よって A を与えて C を取得することができたため、三段論法を定義できた。 + +\section{Agdaで使用するもの} + +\subsection{Agdaの省略記法} +Recode が入力された場合のことを考える。この際、入力時に record を展開してしまうと、 +コードが長くなってしまい、煩雑になってしまう。 +これを防ぐために、withを使用し、必要な変数のみ取り出してパターンマッチを行う。 +例を \coderef{abridgement} に示す。 + +\lstinputlisting[label=abridgement, caption=入力を省略する Agda コードの例, firstline=5] {src/agda/abridgement.agda} + +patternmatch-default は入力されている record をそのまま展開することで、 +値を取得している。 + +patternmatch-extraction では、with を使用して入力されているrecordの中から対象の +値だけ取得している。このように、入力時にrecordを展開せずに中の値を取得することも +できる。 + +patternmatch-extraction' では、入力が同じ場合に ... で省略ができることを使用し、 +さらに省略を行っている。 + +今後のソースコードでは、必要な変数のみ取り出すことでコードを見やすくする。 + +%\subsection{<-cmp} +% 式変形の方が需要があるかもしれない + +% \lstinputlisting[label=syllogism, caption=syllogism, firstline=7,lastline=14] {src/agda/cmp.agda} + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/cbc.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,47 @@ +\chapter{Continuetion based C} + +\section{Continuation based C} +CbC とはC言語からループ制御構造とサブルーチンコールを取り除き、 +継続を導入したC言語の下位言語である。継続呼び出しは引数付き goto 文で表現される。 +また、CodeGear を処理の単位、DataGear をデータの単位として記述するプログラミング言語である。 +CbC のプログラミングでは DataGear を CodeGear で変更し、その変更を次の CodeGear に渡して処理を行う。 + +\section{Code Gear / Data Gear} +CbCでは、検証しやすいプログラムの単位として DataGear と CodeGear という単位を用いる。 + +CodeGear はプログラムの処理そのものであり、一般的なプログラム言語における関数と同じ役割である。 +DataGear は CodeGear で扱うデータの単位であり、処理に必要なデータである。 +CodeGear の入力となる DataGear を Input DataGear と呼び、出力は Output DataGear と呼ぶ。 + +CodeGear 間の移動は継続を用いて行われる。 +継続は関数呼び出しとは異なり、呼び出した後に元のコードに戻れず、次の CodeGear へ継続を行う。 +これは、関数型プログラミングでは末尾再帰をしていることと同義である。 + + +\section{Meta Code Gear / Meta Data Gear} +プログラムの記述する際は、ノーマルレベルの計算の他に、メモリ管理、スレッド管理、 +資源管理等を記述しなければならない処理が存在する。これらの処理をメタ計算と呼ぶ。 + +メタ計算は OS の機能を通して処理することが多く、信頼性の高い記述が求められる。 +そのため、 CbC ではメタ計算を分離するために Meta CodeGear、 Meta DataGear を定義している。 + +Meta CodeGear は CbC 上でのメタ計算で、通常の CodeGear を実行する際に必要なメタ計算を分離するための単位である。 +CodeGear を実行する前後やDataGear の大枠として Meta Gear が存在している。 + +Meta DataGear は CbC 上のメタ計算で扱われる DataGear である。例えば stub +CodeGear では Context と呼ばれる接続可能な CodeGear、DataGear のリストや、DataGear +のメモリ空間等を持った Meta DataGear を扱っている。 + +\section{CbC と C言語の違い} +同じ仕様でCbCとC言語で実装した際の違いを、実際のコードを元に比較する。 +以下はフィボナッチ数列の n 番目を求める CbC と C言語のソースコードである。 + +\lstinputlisting[label=plus, caption=plus, firstline=5] {src/cbc/fib.c} +\lstinputlisting[label=plus, caption=plus, firstline=5] {src/cbc/fib.cbc} + +軽量実装になっているのか、上記のコードをアセンブラ変換した結果を見て確認する。 + +\lstinputlisting[label=plus, caption=plus] {src/cbc/c.out} +\lstinputlisting[label=plus, caption=plus] {src/cbc/cbc.out} + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/cbc_agda.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,33 @@ +\chapter{Continuation based C と Agda} +\section{検証手法} +本章では検証する際の手法を説明する。 +CodeGear の引数となる DataGear が事前条件となり、 +それを検証する為のPre Conditionを検証する為の Meta Gearsが存在する。 +その後、さらに事後条件となる DetaGear も Meta Gears にて検証する。 +これらを用いて Hoare Logic によりプログラムの検証を行いたい。 + +\subsection{CbC記法で書くagda} +Agdaでは関数の再帰呼び出しが可能であるが、CbCでは値が 帰って来ない。そのためAgda +で実装を行う際には再帰呼び出しを行わないようにする。 +\coderef{agda-cg}が例となるコードである。 + +\lstinputlisting[caption= Agdaでの CodeGear の例, label=agda-cg, firstline=6]{src/agda/cbc-agda.agda} + +前述した加算を行うコードと比較すると、不定の型 (t) により継続を行なっている部分が見える。 +これがAgdaで表現された CodeGear となる。 + +\subsection{agda による Meta Gears} +通常の Meta Gears はノーマルレベルの CodeGear、 DataGear では扱えないメタレベルの計算を扱う単位である。 +今回はその Meta Gears をAgdaによる検証の為に用いる。 + +\begin{itemize} +\item Meta DataGear \mbox{}\\ + Agda 上で Meta DataGear を持つことでデータ構造自体が関係を持つデータを作ることができる。 + これを用いることで、仕様となる制約条件を記述することができる。 + +\item Meta CodeGear\mbox{}\\ + Meta CodeGear は 通常の CodeGear では扱えないメタレベルの計算を扱う CodeGear + である。Agda での Meta CodeGear は Meta DataGear を引数に取りそれらの関係を返 + す CodeGear である。故に、Meta CodeGear は Agda で記述した CodeGear の検証そのものである +\end{itemize} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/continuation_agda.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,9 @@ +\section{Code Gearに合わせた Agda} +検証を行うために、AgdaのコードもCbCに合わせて記述を行う必要がある。 +実際に以下がコードとなる。 + +CbCの特徴である、変数を継続して実行するために、必要な変数は Envc に格納する。 +コードに (next : Envc → t) と (exit : Envc → t) を引数に受け取っている。 +これで次の遷移先を引数として受け取る事で、実行を継続していることを示す。 += の後は next Envc もしくは exit Envc となっていることからも +実行を継続している事が分かる。
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/future.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,18 @@ +\chapter{今後の課題} + +\section{今後の課題} +今後の課題として、以下が挙げられる。 +RedBlackTree の基本操作として insert や delete が挙げられる。 +通常は、再代入などを用いて実装を行うと思われるが、Agda が変数への代入を許していないため、 +操作後の RedBlackTree を再構成するように実装を行う必要がある。 +その際にどこの状態の検証を行うかが課題になっている。 + +先行研究にて、 +個々の Code Gear の条件を書いてそれを接続することは Agda で実装されている。 +しかし、接続された条件が健全であるか証明されていない。 + +証明されていない部分というのは、プログラム全体はいくつかの Code Gear の集まりだが、 +Code Gear 実行後の事後条件が正しく次に実行される Code Gear の事前条件として成り立っているか、 +それが最初からプログラムの停止まで正しく行われているかという部分である。 + +今後はこの接続された条件の健全性の証明から行っていく。
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/hoare.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,36 @@ +\chapter{Hoare Logic} + +\section{Hoare Logic} +Hoare Logic\ref{hoare} とは C.A.R Hoare、 +R.W Floyd が考案したプログラムの検証の手法である。 +これは、「プログラムの事前条件(P)が成立しているとき、コマンド(C)実行して停止すると事後条件(Q)が成り立つ」 +というもので、CbCの実行を継続するという性質に非常に相性が良い。 +Hoare Logic を表記すると以下のようになる。 +$$ \{P\}\ C \ \{Q\} $$ +この3つ組は Hoare Triple と呼ばれる。 + +Hoare Triple の事後条件を受け取り、 +異なる条件を返す別の Hoare Triple を繋げることでプログラムを記述していく。 + +Hoare Logic の検証では、 +「条件がすべて正しく接続されている」かつ「コマンドが停止する」ことが必要である。 +これらを満たし、 +事前条件から事後条件を導けることを検証することで Hoare Logic の健全性を示すことができる。 + +\section{Hoare による Code Gear の検証 } + +\figref{hoare}が agda にて Hoare Logic を用いて Code Gear を検証する際の流れになる。 +input DataGear が Hoare Logic上の Pre Condition(事前条件)となり、 +output DataGear が Post Conditionとなる。 +各DataGear が Pre / Post Condition を満たしているかの検証は、 +各 Condition を Meta DataGear で定義し、 +条件を満たしているのかをMeta CodeGear で検証する。 + +\begin{center} +\includegraphics[height=3.4cm]{pic/hoare_cg_dg.pdf} +%\caption{CodeGear、DataGear での Hoare Logic} +\label{hoare} +\end{center} + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/intro.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,52 @@ +\chapter{はじめに} +\pagenumbering{arabic} + +OSやアプリケーションの信頼性を高めることは重要な課題である。 +信頼性を高める為にはプログラムが仕様を満たした実装を検証する必要がある。 +具体的には「モデル検査」や「定理証明」などが検証手法としてあげられる。 + +当研究室では Continuation based C (CbC) という言語を開発している。 +CbC とは、C言語からループ制御構造とサブルーチンコールを取り除き、 +継続を導入した C言語の下位言語である。 +その為、それを実装した際のプログラムが正確に動作するのか検証を行いたい。 + +\section{研究目的} +仕様に合った実装を実施していることの検証手法として Hoare Logic が知られている。 +Hoare Logic は事前条件が成り立っているときにある計算(以下コマンド)を実行した後に、 +事後条件が成り立つことでコマンドの検証を行う。 +この定義が CbC の実行を継続するという性質と相性が良い。 + +CbCでは実行を継続するため、ある関数の実行結果は事後条件になるが、 +その実行結果が遷移する次の関数の事前条件になる。 +それを繋げていくため、個々の関数の +正当性を証明することと接続の健全性について証明するだけでプログラム全体の検証を行うことができる。 + +CbCではループ制御構造を取り除いているため、 +CbCにてループが含まれるプログラムを作成した際の検証を行う必要がある。 +先行研究ではCbCにおけるWhileLoopの検証を行なっている。 + +Agdaが変数への再代入を許していない為、 +ループが存在し、かつ再代入がプログラムに含まれる RedBlackTree の検証を行いたい。 + +% これらのことから、本稿では Hoare Logic を用いて CbC を検証することを目指す。 +これらのことから、CbC に対応するように Agda で RedBlackTree を記述し、 +Hoare Logic により検証を行うことを目指す。 + +\section{論文の構成} +本論文は以下の流れで構成されている。 + +\begin{itemize} +\item 第1章は, 本研究の背景と目的を述べる +\item 第2章は, 検証を行う CbC について述べる +\item 第3章は, 証明に使用する言語である Agda について述べる +\item 第4章は, 検証手法である Hoare Logic について述べる +\item 第5章は, Agda を Continuation style で記述する方法について述べる +\item 第6章は, Red Back Tree について述べる +\item 第7章は、Agda での Red Black Tree の実装方法について述べる +\item 第8章は、Red Black Tree の Hoare Logic を用いた検証について述べる +\item 第9章は, 本研究におけるまとめと今後の課題について述べる +\end{itemize} + + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/intro/intro.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,15 @@ +\section{研究目的} + OS やアプリケーションの信頼性を高めることは重要な課題である。 + 信頼性を高める為には仕様を満たしたプログラムが実装されていることを検証する必要がある。 + 具体的には「モデル検査」や「定理証明」などが検証手法として挙げられる。 + + 研究室で CbC という言語を開発している。 + CbC とは、C言語からループ制御構造とサブルーチンコールを取り除き、継続を導入した C言語の下位言語である。 + この言語の信用性を検証したい。 + + 仕様に合った実装を実施していることの検証手法として Hoare Logic が知られている。 + Hoare Logic は事前条件が成り立っているときにある計算(以下コマンド)を実行した後に、 + に事後条件が成り立つことでコマンドの検証を行う。 + + CbC の実行を継続するという性質が Hoare Logic の事前条件と事後条件の定義から検証を行うことと非常に相性が良い。 + これらのことから、本稿では Hoare Logic を用いて CbC を検証することを目指す。
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/rbt_imple.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,14 @@ +\chapter{Red Black Tree の実装} + +\section{Agda による Red Black Tree の 実装} +通常は再起処理を使用して Red Black Tree を行う。 +しかし、今回はCbCで実装された Red Black Tree を検証するので、 +下図の手順を元に実装を行う。 + +上記に示した手順通りにAgdaで記述すると以下のようなソースコードになる。 + + +以上のように Tree の基本操作である insert, find, delete の実装を行った。 + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/rbt_intro.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,48 @@ +\chapter{Red Black Tree} + +\section{Tree} +Tree (木構造)とは、非常に有用なデータ構造である。 +下図の○の部分を node (節) と呼び、top node を root(根) と呼ぶ。 +特に、根を持つ木構造のことを強調して、Rooted Tree (根付き木) と呼ぶ事がある。 + +\section{Binary Tree} +各 node からすぐ下に辺で結ばれている node をその node の child またはson (子ある +いは子供)と呼ぶ。 child 側から上の辺を parent (親) と呼ぶ。 +下図のように、各 node が持つ child が高々2つである Tree を Binary Tree (2分木)と呼ぶ。 + +\section{Binary Search Tree} +Rooted Binary Tree に対して、 以下の制約を持つものを、Binary Search Tree と呼ぶ。 + +$左側の子孫にある要素 < 親 < 右側の子孫にある要素$ + +\section{RedBlackTree} +RedBlackTree (または赤黒木)とは平衡2分探索木の一つである。 +2分探索木の点にランクという概念を追加し、そのランクの違いを赤と黒の色で分け、以下の定義に基づくように +木を構成した物である。図では省略しているが、値を持っている点の下に黒色の空の葉があり、それが外点となる。 + +\begin{enumerate} + \item 各点は赤か黒の色である。 + \item 点が赤である場合の親となる点の色は黒である。 + \item 外点(葉。つまり一番下の点)は黒である。 + \item 任意の点から外点までの黒色の点はいずれも同数となる。 +\end{enumerate} +参考となる\figref{rbtree}を以下に示す。上記の定義を満たしていることが分かる。 +\begin{center} +\includegraphics[height=3.5cm]{pic/rbtree.pdf} +%\caption{RedBlackTree の一例} +\label{rbtree}% +\end{center} + +\section{Left Learing Red Black Tree} +Left Learing Red Black Tree とは Red Black Tree の変形である。 +Red Black Tree の 仕様を満たしながら、実装が容易である。 + +以下の図のように、 +赤色の node は parent から見て左の node にしか 現れない Red Black Tree となる。 +これにより、パターンマッチの分岐を減らす事ができ、実装が容易になる。 + +本来の Red Black Tree の実装は困難であるため、本論では Red Black Tree の仕様を満たしている +Left Learning Red Black Tree を検証する。 + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/rbt_verif.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,11 @@ +\chapter{Red Black Tree の検証} + +Input Data Gear が Pre Condition を、 Output Data Gearが Post Condition を 満たしているか検証することで Hoare Logic に当てはめる。 + +以下の要素を検証するための Meta Code Gear を実装する。 + + +そして、 Meta Code Gear から 生成される Meta Data Gear が Pre / Post Conditionを +満たしているのか確認することで、関数一つ一つに対して Hoare Logic を用いた検証を行う + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/spec.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,31 @@ +\section{検証手法} +本章では検証する際の手法を説明する。 +CodeGear の引数となる DataGear が事前条件となり、 +それを検証する為のPre Conditionを検証する為の Meta Gearsが存在する。 +その後、さらに事後条件となる DetaGear も Meta Gears にて検証する。 +これらを用いて Hoare Logic によりプログラムの検証を行いたい。 + +\subsection{CbC記法で書くagda} +CbCプログラムの検証をするに当たり、AgdaコードもCbC記法で記述を行う。つまり継続渡しを用いて記述する必要がある。 +\coderef{agda-cg}が例となるコードである。 + +\lstinputlisting[caption= Agdaでの CodeGear の例, label=agda-cg]{src/cbc-agda.agda} + +前述した加算を行うコードと比較すると、不定の型 (t) により継続を行なっている部分が見える。 +これがAgdaで表現された CodeGear となる。 + +\subsection{agda による Meta Gears} +通常の Meta Gears はノーマルレベルの CodeGear、 DataGear では扱えないメタレベルの計算を扱う単位である。 +今回はその Meta Gears をAgdaによる検証の為に用いる。 + +\begin{itemize} + \item Meta DataGear \mbox{}\\ + Agda 上で Meta DataGear を持つことでデータ構造自体が関係を持つデータを作ることができる。 + これを用いることで、仕様となる制約条件を記述することができる。 + + \item Meta CodeGear\mbox{}\\ + Meta CodeGear は 通常の CodeGear では扱えないメタレベルの計算を扱う CodeGear + である。Agda での Meta CodeGear は Meta DataGear を引数に取りそれらの関係を返 + す CodeGear である。故に、Meta CodeGear は Agda で記述した CodeGear の検証そのものである +\end{itemize} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/spec/spec.tex Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,24 @@ +\section{検証手法} + 手法は模索中であり、先行研究と同じ手法を取ろうとしている。本章では先行研究で述べられている検証手法について説明する。 +\subsection{CbC記法で書くagda} + CbCプログラムの検証をするに当たり、agdaコードもCbC記法で記述を行う。つまり継続渡しを用いて記述する必要がある。 + 以下が例となるコードである。 + 前述した加算を行うコードと比較すると、不定の型 (t) により継続を行なっている部分が見える。 + これがAgdaで表現された CodeGear となる。 + +\subsection{agda による Meta Gears} + 通常の Meta Gears はノーマルレベルの CodeGear、 DataGear では扱えないメタレベルの計算を扱う単位である。 + Meta DataGear はメタ計算で使われる DataGear で、実行するメタ計算によって異なる。 + 今回はその Meta Gears をagdaによる検証の為に用いる。 + 検証での Meta Gears は DataGear が持つ同値関係や、 + 大小関係などの関係を表す DataGear がそれに当たると考えられる。 + Agda 上で Meta DataGear を持つことでデータ構造自体が関係を持つデータを作ることができる。 + 以下が While Program での制約条件をまとめたものになる。 + Agdaにおける Meta DataGear のコードを載せる。 + \lstinputlisting[label=pg:sample]{./src/agda-mdg.agda} + whileTestState で Meta DataGear を識別するためのデータを分け、 + whileTestStatePでそれぞれの Meta DataGear を返している。 + ここでは = の後ろの (vari env ≡ 0) (varn env ≡ + c10 env)/ などのデータを Meta DataGear として扱う。 + aa +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/spec/src/agda-mcg.agda Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +whileTestPwP : {l : Level} {t : Set l} → (c10 : ℕ) → + ((env : Envc ) → (mdg : (vari env ≡ 0) /\ (varn env ≡ c10 env)) → t) → t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( λ env → env )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/paper/tex/spec/src/agda-mcg.agda.replaced Tue Feb 09 18:44:53 2021 +0900 @@ -0,0 +1,5 @@ +whileTestPwP : {l : Level} {t : Set l} @$\rightarrow$@ (c10 : @$\mathbb{N}$@) @$\rightarrow$@ + ((env : Envc ) @$\rightarrow$@ (mdg : (vari env @$\equiv$@ 0) @$\wedge$@ (varn env @$\equiv$@ c10 env)) @$\rightarrow$@ t) @$\rightarrow$@ t +whileTestPwP c10 next = next env record { pi1 = refl ; pi2 = refl } where + env : Envc + env = whileTestP c10 ( @$\lambda$@ env @$\rightarrow$@ env )