From bbf6abeee413c2ed83eff83d980bdd0e21c55594 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 2 Sep 2024 19:41:34 -0400 Subject: [PATCH 01/49] First tactics commit --- lib/basic/tactics.ath | 70 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 lib/basic/tactics.ath diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath new file mode 100644 index 0000000..5da84f3 --- /dev/null +++ b/lib/basic/tactics.ath @@ -0,0 +1,70 @@ +module Tactics { + +# A record (or frame) on the goal stack has the following form: +# |{ +# 'goal := , +# 'id := , +# 'assumptions := , +# 'eigenvariables := , +# 'witnesses := , +# 'partial-proof := , +# 'tactic-history := +# }| + + +private define goal-stack := (cell []) + +private define goal-id-counter := (cell 0) + +private define fresh-goal-id := lambda () (join "g-" (val->string (inc goal-id-counter))) + +private define set-goal := lambda (g) (set! goal-stack [g]) + +# Apply a given tactic to the topmost goal: + +define (backward-tactic goal-stack) := + match goal-stack { + (list-of goal-record rest) => + match (goal-record 'goal) { + (and (some-list conjuncts)) => + let {make-new-goal-record := lambda (subgoal) + |{ + 'goal := p1, + 'id := (fresh-goal-id), + 'assumptions := (goal-record 'assumptions), + 'eigenvariables := (goal-record 'eigenvariables), + 'witnesses := (goal-record 'witnesses), + 'partial-proof := (goal-record 'partial-proof), + 'tactic-history := (add 'backward (goal-record 'tactic-history)) + }|; + new-goal-records := (map make-new-goal-record conjuncts)} + (join new-goal-records rest) + | (if (some-sentence p) (some-sentence q)) => + let {goal-record' := |{ + 'goal := q, + 'id := (fresh-goal-id), + 'assumptions := (add p (goal-record 'assumptions)), + 'eigenvariables := (goal-record 'eigenvariables), + 'witnesses := (goal-record 'witnesses), + 'partial-proof := (goal-record 'partial-proof), + 'tactic-history := (add 'backward (goal-record 'tactic-history)) + }|} + (add goal-record' rest) + } + | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") + } + + +define tactic-dictionary := + |{ + 'backward := backward-tactic + }| + +define (apply-tactic tactic-description) := + let {tactic := (tactic-dictionary tactic-description)} + (tactic (ref goal-stack)) + +} # close module Tactics + +EOF +load "lib/basic/tactics" \ No newline at end of file From ee8261ad3bb00b2b38cd1235f921f449d70c5f0f Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Tue, 3 Sep 2024 10:30:52 -0400 Subject: [PATCH 02/49] Progress on process --- ft/data/book/process.py | 141 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 ft/data/book/process.py diff --git a/ft/data/book/process.py b/ft/data/book/process.py new file mode 100644 index 0000000..053a815 --- /dev/null +++ b/ft/data/book/process.py @@ -0,0 +1,141 @@ +import sys +sys.path.append('/mnt/c/code/python') +from utils1 import * + + +def findNthOccurrence(s,pat,n): + start = -1 + for _ in range(n): + start = s.find(pat,start+1) + if start == -1: + return -1 + return start + +def grabLines(L,i,N): + j = i + block = [] + while not(L[j].startswith("]]]]")) and j < N: + block.append(L[j]) + j += 1 + if j < N: + block.append(L[j]) + return (block,j) + +def getProofBlocks(L): + i = 0 + N = len(L) + blocks = [] + while (i < N): + if L[i].startswith("[[[["): + (block, j) = grabLines(L,i,N) + blocks.append(block) + i = j + 1 + else: + i += 1 + return blocks + + +def updateParenState(paren_state,c): + if c == '(': + paren_state['parens'] += 1 + elif c == '[': + paren_state['brackets'] += 1 + elif c == '{': + paren_state['braces'] += 1 + elif c == ')': + paren_state['parens'] -= 1 + elif c == ']': + paren_state['brackets'] -= 1 + elif c == '}': + paren_state['braces'] -= 1 + else: + pass + + +def checkBalance(text): + paren_state = {'parens':0, 'brackets':0, 'braces':0} + for c in text: + updateParenState(paren_state,c) + return paren_state + +def balanced(paren_state): + return paren_state['parens'] == 0 and paren_state['brackets'] == 0 and paren_state['braces'] == 0 + +def balanceText(text,paren_state): + # It's assumed that the input paren_state is unbalanced. + N = len(text) + i = 0 + res = '' + while (i < N): + c = text[i] + res = res + c + updateParenState(paren_state,c) + #print("Inside the loop, i: " + str(i) + ", c: " + c + ", and paren_state: " + str(paren_state)) + if balanced(paren_state): + return res + else: + i += 1 + if balanced(paren_state): + return res + else: + print("UNABLE TO BALANCE REMAINDER!") + raise Exception("UNABLE TO BALANCE REMAINDER!") + +def getText(lines,start,end): + (line1,pos1) = start + (line2,pos2) = end + subtract = len(lines[line2])-pos2 + span_text = ''.join(lines[line1:line2+1])[pos1:] + span_text_clipped = span_text[:-subtract] + remaining_text_starting_line = lines[line2][pos2:] + all_remaining_lines = [remaining_text_starting_line] + lines[line2+1:] + all_remaining_text = ''.join(all_remaining_lines) + paren_state = checkBalance(span_text_clipped) + if balanced(paren_state): + return span_text_clipped + else: + return span_text_clipped + balanceText(all_remaining_text,paren_state) + +def analyzeBlock(block): + ''' + This function takes a proof block and extracts the proof and the proof's metadata from it. The input block is just a list of lines, + and the output is a dictionary of this form: + {'proof': , + 'file': , + 'start_pos': , + 'end_pos': , + 'conclusion': , + 'free-ids': + 'fun-syms': , + 'structures': , + 'domains': Date: Wed, 4 Sep 2024 09:55:34 -0400 Subject: [PATCH 03/49] Subproof extraction working --- ft/data/book/process.py | 129 +++++++++++++++++++++++++++++++++------- 1 file changed, 108 insertions(+), 21 deletions(-) diff --git a/ft/data/book/process.py b/ft/data/book/process.py index 053a815..4c16603 100644 --- a/ft/data/book/process.py +++ b/ft/data/book/process.py @@ -51,7 +51,6 @@ def updateParenState(paren_state,c): else: pass - def checkBalance(text): paren_state = {'parens':0, 'brackets':0, 'braces':0} for c in text: @@ -81,9 +80,15 @@ def balanceText(text,paren_state): print("UNABLE TO BALANCE REMAINDER!") raise Exception("UNABLE TO BALANCE REMAINDER!") -def getText(lines,start,end): - (line1,pos1) = start - (line2,pos2) = end +def getBalancedText(lines,start_pos,end_pos): + ''' + lines:A string of lines representing the entire literal contents of the original source file for the proof of interest + start_pos: A pair of integers (line,pos), 0-indexed, representing the starting position (line and column number) for the proof or subproof of interest + end_pos: A pair of integers (line,pos), 0-indexed, representing the ending position (line and column number) for the proof or subproof of interest + Output: The text of the unique proof that starts at start_pos and ends either at end_pos or beyond. + ''' + (line1,pos1) = start_pos + (line2,pos2) = end_pos subtract = len(lines[line2])-pos2 span_text = ''.join(lines[line1:line2+1])[pos1:] span_text_clipped = span_text[:-subtract] @@ -96,21 +101,76 @@ def getText(lines,start,end): else: return span_text_clipped + balanceText(all_remaining_text,paren_state) + +def getSingleFidContent(single_fid_text): + #print("\nWorking on this single fid entry: " + single_fid_text) + s = single_fid_text + chunks = [chunk.strip() for chunk in s.split(' || ')] + # By convention, we must have exactly three ||-separated chunks: + assert len(chunks) == 3 + fid_name_literal, fid_type_literal, fid_value_literal = 'fidName:', 'fidType:', 'fidValue:' + # Get name first: + fid_name = chunks[0][len(fid_name_literal):].strip() + # Then get type: + fid_type = chunks[1][len(fid_type_literal):].strip() + # And finally value: + fid_value = chunks[2][len(fid_value_literal):].strip() + return {'fid_name': fid_name, 'fid_type': fid_type, 'fid_value': fid_value} + +def getFidBlockInfo(fid_content): + R = [] + i = 0 + while (fid_content.find("fidName: ",i)) >= 0: + i = fid_content.find("fidName: ",i) + next = fid_content.find("fidName: ",i + 1 + len('fidName: ')) + single_fid_text = fid_content[i:] if next < 0 else fid_content[i:next].strip() + R.append(getSingleFidContent(single_fid_text)) + i = next + return R + +def getRange(text): + line_index_1 = findNthOccurrence(text,':',2) + pos_index_1 = text.find(':',line_index_1+1) + starting_line = int(text[line_index_1+1:pos_index_1].strip()) + pos_1_end = text.find("and ending at: ") + if pos_1_end < 0: + pos_1_end = len(text) + starting_pos = int(text[pos_index_1+1:pos_1_end].strip()) + return (starting_line,starting_pos) + +def subproofStartingAndEndingPositions(subproof_chunk): + (starting_line,starting_pos) = getRange(subproof_chunk) + pat = " and ending at: " + pos_1_end = subproof_chunk.find(pat) + rem_text = subproof_chunk[pos_1_end+4:subproof_chunk.find('\n')] + (ending_line,ending_pos) = getRange(rem_text) + return ((starting_line-1,starting_pos-1), (ending_line-1,ending_pos-1)) + +def getSubproofs(subproof_content,source_file,all_source_file_lines): + chunks = [chunk.strip() for chunk in subproof_content.split("||\n")] + R = [] + for chunk in chunks: + (subproof_starting_pos,subproof_ending_pos) = subproofStartingAndEndingPositions(chunk) + subproof_text = getBalancedText(all_source_file_lines,subproof_starting_pos,subproof_ending_pos) + R.append({'subproof_text': subproof_text, 'file': source_file, 'starting_pos': {'line': subproof_starting_pos[0], 'col': subproof_starting_pos[1]}, 'ending_pos': {'line': subproof_ending_pos[0], 'col': subproof_ending_pos[1]}}) + return R + def analyzeBlock(block): ''' This function takes a proof block and extracts the proof and the proof's metadata from it. The input block is just a list of lines, and the output is a dictionary of this form: - {'proof': , - 'file': , - 'start_pos': , - 'end_pos': , - 'conclusion': , - 'free-ids': - 'fun-syms': , - 'structures': , - 'domains': , + 'file': , + 'start_pos': , + 'end_pos': , + 'conclusion': , + 'subproofs': + 'free-ids': + 'fun-syms': , + 'structures': , + 'domains': Date: Wed, 4 Sep 2024 10:33:31 -0400 Subject: [PATCH 04/49] Fid dictionaries instead of lists --- ft/data/book/process.py | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/ft/data/book/process.py b/ft/data/book/process.py index 4c16603..ce3825b 100644 --- a/ft/data/book/process.py +++ b/ft/data/book/process.py @@ -118,15 +118,16 @@ def getSingleFidContent(single_fid_text): return {'fid_name': fid_name, 'fid_type': fid_type, 'fid_value': fid_value} def getFidBlockInfo(fid_content): - R = [] + F = {} i = 0 while (fid_content.find("fidName: ",i)) >= 0: i = fid_content.find("fidName: ",i) next = fid_content.find("fidName: ",i + 1 + len('fidName: ')) single_fid_text = fid_content[i:] if next < 0 else fid_content[i:next].strip() - R.append(getSingleFidContent(single_fid_text)) + r = getSingleFidContent(single_fid_text) + F[r['fid_name']] = {'fid_type': r['fid_type'], 'fid_value': r['fid_value']} i = next - return R + return F def getRange(text): line_index_1 = findNthOccurrence(text,':',2) @@ -165,8 +166,8 @@ def analyzeBlock(block): 'end_pos': , 'conclusion': , 'subproofs': - 'free-ids': - 'fun-syms': , + 'free-ids': + 'fun-syms': , 'structures': , 'domains': Date: Wed, 4 Sep 2024 17:37:47 -0400 Subject: [PATCH 05/49] WIP --- ft/data/book/process.py | 30 ++++++++++++++++++++++++++---- lib/basic/tactics.ath | 36 ++++++++++++++++++++++++++++++++---- 2 files changed, 58 insertions(+), 8 deletions(-) diff --git a/ft/data/book/process.py b/ft/data/book/process.py index ce3825b..b9f7c5e 100644 --- a/ft/data/book/process.py +++ b/ft/data/book/process.py @@ -156,6 +156,24 @@ def getSubproofs(subproof_content,source_file,all_source_file_lines): R.append({'subproof_text': subproof_text, 'file': source_file, 'starting_pos': {'line': subproof_starting_pos[0], 'col': subproof_starting_pos[1]}, 'ending_pos': {'line': subproof_ending_pos[0], 'col': subproof_ending_pos[1]}}) return R +def processFsymChunk(chunk,D,file_name,all_source_file_lines): + toks = [t.strip() for t in chunk.split(" || ")] + assert (len(toks) == 3) + sym_name = getSymbolName(toks[0]) + sym_type = getSymbolType(toks[1]) + sym_signature = getSignate + if sym_type == 'constructor': + getStructureDefs(toks[2]) + else: + + +def processFsymContent(fsym_content,file_name,all_source_file_lines): + chunks = [chunk.strip() for chunk in fsym_content.split("||\n")] + D = {} + for chunk in chunks: + processFsymChunk(chunk,D,file_name,all_source_file_lines) + return D + def analyzeBlock(block): ''' This function takes a proof block and extracts the proof and the proof's metadata from it. The input block is just a list of lines, @@ -182,7 +200,7 @@ def analyzeBlock(block): diff = column_start_pos - line_start_pos - 1 line_number = header_line[line_start_pos:line_start_pos+diff] col_number = header_line[column_start_pos:].strip() - proof_starting_position = {'line': int(line_number)-1, 'pos': int(col_number)-1} + proof_starting_position = {'line': int(line_number)-1, 'col': int(col_number)-1} second_line = block[2] i = findNthOccurrence(second_line,':',3) proof_end_line = int(second_line[1+findNthOccurrence(second_line,':',2):i])-1 @@ -193,7 +211,7 @@ def analyzeBlock(block): last_eol_pos = proof_text.rstrip().rfind('\n') last_eol_pos = 0 if last_eol_pos < 0 else last_eol_pos last_chunk = proof_text[1+last_eol_pos:].rstrip() - proof_ending_position = {'line': proof_starting_position['line']+lines_in_proof_text-1,'pos': len(last_chunk)-1} + proof_ending_position = {'line': proof_starting_position['line']+lines_in_proof_text-1,'col': len(last_chunk)-1} # So far: proof_text, file_name,proof_starting_position, proof_ending_position conclusion_pat = 'Conclusion:\n{{{' conclusion_pos = text.find(conclusion_pat) @@ -212,8 +230,12 @@ def analyzeBlock(block): subproofs_end = text.find('}}}',subproofs_start+len(subproof_pat)) subproof_content = text[subproofs_start+len(subproof_pat):subproofs_end].strip() subproof_list = sorted(getSubproofs(subproof_content,file_name,all_source_file_lines),key=lambda subproof: len(subproof['subproof_text'])) - - + #**** Function Symbols: + fsym_pat = "Function symbols:\n{{{" + fsym_start_pos = text.find(fsym_pat) + fsym_end_pos = text.find('}}}',fsym_start_pos+len(fsym_pat)) + fsym_content = text[fsym_start_pos+len(fsym_pat):fsym_end_pos].strip() + fsym_dict = processFsymContent(fsym_content,file_name,all_source_file_lines) def processFile(file): L = getTotallyLiteralLines(file) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 5da84f3..eaf2996 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -22,7 +22,7 @@ private define set-goal := lambda (g) (set! goal-stack [g]) # Apply a given tactic to the topmost goal: -define (backward-tactic goal-stack) := +define (backward-tactic goal-stack tactic-name) := match goal-stack { (list-of goal-record rest) => match (goal-record 'goal) { @@ -35,7 +35,7 @@ define (backward-tactic goal-stack) := 'eigenvariables := (goal-record 'eigenvariables), 'witnesses := (goal-record 'witnesses), 'partial-proof := (goal-record 'partial-proof), - 'tactic-history := (add 'backward (goal-record 'tactic-history)) + 'tactic-history := (add 'back-and (goal-record 'tactic-history)) }|; new-goal-records := (map make-new-goal-record conjuncts)} (join new-goal-records rest) @@ -47,9 +47,33 @@ define (backward-tactic goal-stack) := 'eigenvariables := (goal-record 'eigenvariables), 'witnesses := (goal-record 'witnesses), 'partial-proof := (goal-record 'partial-proof), - 'tactic-history := (add 'backward (goal-record 'tactic-history)) + 'tactic-history := (add 'back-if (goal-record 'tactic-history)) }|} (add goal-record' rest) + | (iff (some-sentence p) (some-sentence q)) => + let {goal-record' := |{ + 'goal := (and (if p q) (if q p)), + 'id := (fresh-goal-id), + 'assumptions := (goal-record 'assumptions), + 'eigenvariables := (goal-record 'eigenvariables), + 'witnesses := (goal-record 'witnesses), + 'partial-proof := (goal-record 'partial-proof), + 'tactic-history := (add 'back-iff (goal-record 'tactic-history)) + }|} + (add goal-record' rest) + | (or (some-sentence p) (some-sentence q)) => + let {[new-goal new-assumption] := check {(tactic-name equals? 'back-lor) => [p q] | else => [q p]}; + goal-record' := |{ + 'goal := new-goal, + 'id := (fresh-goal-id), + 'assumptions := (add new-assumption (goal-record 'assumptions)), + 'eigenvariables := (goal-record 'eigenvariables), + 'witnesses := (goal-record 'witnesses), + 'partial-proof := (goal-record 'partial-proof), + 'tactic-history := (add tactic-name (goal-record 'tactic-history)) + }|} + + | _ => goal-stack } | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") } @@ -57,7 +81,11 @@ define (backward-tactic goal-stack) := define tactic-dictionary := |{ - 'backward := backward-tactic + 'back-lor := lambda (goal-stack) (backward-tactic goal-stack 'lor), + 'back-ror := lambda (goal-stack) (backward-tactic goal-stack 'ror), + 'back-if := lambda (goal-stack) (backward-tactic goal-stack 'ror), + 'back-iff := lambda (goal-stack) (backward-tactic goal-stack 'ror), + 'back-and := lambda (goal-stack) (backward-tactic goal-stack 'ror), }| define (apply-tactic tactic-description) := From faea1fc8415e768aad4204f905757576c84f99b7 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Fri, 6 Sep 2024 09:16:41 -0400 Subject: [PATCH 06/49] WIP --- lib/basic/tactics.ath | 126 ++++++++++++++++++++++++------------------ topenv_part2.sml | 7 ++- 2 files changed, 79 insertions(+), 54 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index eaf2996..db85f2d 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -7,72 +7,77 @@ module Tactics { # 'assumptions := , # 'eigenvariables := , # 'witnesses := , -# 'partial-proof := , -# 'tactic-history := +# 'parent := +# 'children := # }| -private define goal-stack := (cell []) + define goal-stack := (cell []) -private define goal-id-counter := (cell 0) + define goal-id-counter := (cell 0) -private define fresh-goal-id := lambda () (join "g-" (val->string (inc goal-id-counter))) + define ht := (HashTable.table 500) -private define set-goal := lambda (g) (set! goal-stack [g]) + define root-id := (cell "g1") + + define fresh-goal-id := lambda () (join "g" (val->string (inc goal-id-counter))) + + define clear-state := + lambda () + (seq (HashTable.clear ht) + (set! goal-id-counter 0)) + +define set-goal := + lambda (goal-sentence) + let {_ := (clear-state); + root := (fresh-goal-id); + _ := (set! root-id root)} + (set! goal-stack [|{'id := root, + 'goal := goal-sentence, + 'assumptions := [], + 'eigenvariables := [], + 'witnesses := [], + 'parent := (cell ()), + 'children := (cell [])}|]) + +define (set-parent g1 g2) := +# Make g1 the parent of g2 and g2 a child of g1: + let {_ := (set! (g1 'children) + (join (ref (g1 'children)) [g2]))} + (seq (set! (g2 'parent) g1)) + +define (set-parent* g1 goal-records) := + (map-proc (lambda (g) (set-parent g1 g)) goal-records) # Apply a given tactic to the topmost goal: +define (make-new goal-record new-bindings) := + (Map.add goal-record (join [['parent (cell ())] ['id (fresh-goal-id)] ['children (cell [])]] new-bindings)) + define (backward-tactic goal-stack tactic-name) := match goal-stack { (list-of goal-record rest) => match (goal-record 'goal) { (and (some-list conjuncts)) => - let {make-new-goal-record := lambda (subgoal) - |{ - 'goal := p1, - 'id := (fresh-goal-id), - 'assumptions := (goal-record 'assumptions), - 'eigenvariables := (goal-record 'eigenvariables), - 'witnesses := (goal-record 'witnesses), - 'partial-proof := (goal-record 'partial-proof), - 'tactic-history := (add 'back-and (goal-record 'tactic-history)) - }|; - new-goal-records := (map make-new-goal-record conjuncts)} - (join new-goal-records rest) + let {make-new-goal-record := lambda (conjunct) (make-new goal-record [['goal conjunct]]); + new-goal-records := (map make-new-goal-record conjuncts); + _ := (set-parent* goal-record new-goal-records); + new-stack := (join new-goal-records rest); + _ := (print "\nNEW STACK: " new-stack)} + new-stack | (if (some-sentence p) (some-sentence q)) => - let {goal-record' := |{ - 'goal := q, - 'id := (fresh-goal-id), - 'assumptions := (add p (goal-record 'assumptions)), - 'eigenvariables := (goal-record 'eigenvariables), - 'witnesses := (goal-record 'witnesses), - 'partial-proof := (goal-record 'partial-proof), - 'tactic-history := (add 'back-if (goal-record 'tactic-history)) - }|} + let {goal-record' := (make-new goal-record [['goal q] ['assumptions (add p (goal-record 'assumptions))]]); + _ := (set-parent goal-record goal-record')} (add goal-record' rest) | (iff (some-sentence p) (some-sentence q)) => - let {goal-record' := |{ - 'goal := (and (if p q) (if q p)), - 'id := (fresh-goal-id), - 'assumptions := (goal-record 'assumptions), - 'eigenvariables := (goal-record 'eigenvariables), - 'witnesses := (goal-record 'witnesses), - 'partial-proof := (goal-record 'partial-proof), - 'tactic-history := (add 'back-iff (goal-record 'tactic-history)) - }|} + let {goal-record' := (make-new goal-record [['goal (and (if p q) (if q p))]]); + _ := (set-parent goal-record goal-record')} (add goal-record' rest) | (or (some-sentence p) (some-sentence q)) => let {[new-goal new-assumption] := check {(tactic-name equals? 'back-lor) => [p q] | else => [q p]}; - goal-record' := |{ - 'goal := new-goal, - 'id := (fresh-goal-id), - 'assumptions := (add new-assumption (goal-record 'assumptions)), - 'eigenvariables := (goal-record 'eigenvariables), - 'witnesses := (goal-record 'witnesses), - 'partial-proof := (goal-record 'partial-proof), - 'tactic-history := (add tactic-name (goal-record 'tactic-history)) - }|} - + goal-record' := (make-new goal-record [['goal new-goal] ['assumptions (add new-assumption (goal-record 'assumptions))]]); + _ := (set-parent goal-record goal-record')} + (add goal-record' rest) | _ => goal-stack } | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") @@ -82,16 +87,31 @@ define (backward-tactic goal-stack tactic-name) := define tactic-dictionary := |{ 'back-lor := lambda (goal-stack) (backward-tactic goal-stack 'lor), - 'back-ror := lambda (goal-stack) (backward-tactic goal-stack 'ror), - 'back-if := lambda (goal-stack) (backward-tactic goal-stack 'ror), - 'back-iff := lambda (goal-stack) (backward-tactic goal-stack 'ror), - 'back-and := lambda (goal-stack) (backward-tactic goal-stack 'ror), + 'back-ror := lambda (goal-stack) (backward-tactic goal-stack 'back-ror), + 'back-if := lambda (goal-stack) (backward-tactic goal-stack 'back-if), + 'back-iff := lambda (goal-stack) (backward-tactic goal-stack 'back-iff), + 'back-and := lambda (goal-stack) (backward-tactic goal-stack 'back-end), }| -define (apply-tactic tactic-description) := - let {tactic := (tactic-dictionary tactic-description)} - (tactic (ref goal-stack)) +define (apply-tactic tactic-name) := + let {# Retrieve the tactic by name: + tactic := (tactic-dictionary tactic-name); + # Apply the tactic to the goal-stack: + new-stack := (tactic (ref goal-stack))} + (set! goal-stack new-stack) + +define (show-goal-record g i N) := + (print "\n*** Stack record #" i " out of " N ":\n--Goal: " (g 'goal) "\n--Goal id: " (g 'id) + "\n--Assumptions:\n" (g 'assumptions) "\n--Eigenvariables: " (g 'eigenvariables) "\n--Witnesses: " (g 'witnesses)) +define (show-stack) := + let {counter := (cell 0); + N := (length (ref goal-stack))} + (seq (print "\n[[[[[[[[[[[[[\n") + (map-proc (lambda (r) (show-goal-record r (inc counter) N)) + (ref goal-stack)) + (print "\n]]]]]]]]]]]]]")) + } # close module Tactics EOF diff --git a/topenv_part2.sml b/topenv_part2.sml index 5ba63e6..7c83e66 100644 --- a/topenv_part2.sml +++ b/topenv_part2.sml @@ -1584,7 +1584,12 @@ fun hashPrimUFun(v,_,_) = SOME(P) => let val res = Word.toString(Prop.fastHash(P)) in MLStringToAthString(res) end - | _ => MLStringToAthString(Word.toString(AT.fastHash(t))))) + | _ => MLStringToAthString(Word.toString(AT.fastHash(t)))) + | _ => let val v_str = valToString(v) + val hash = Basic.hashString(v_str) + in + MLStringToAthString(Word.toString(hash)) + end) fun hashIntFun([propVal(P)],_,_) = let val res = Word.toInt(Prop.hash(P)) From a10130a56eed1e5f1458a86413025594a022d82b Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 14 Oct 2024 10:03:51 -0400 Subject: [PATCH 07/49] Refactoring tactics --- lib/basic/tactics.ath | 114 ++++++++++++++++++++++++++---------------- 1 file changed, 70 insertions(+), 44 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index db85f2d..d2cb347 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -3,10 +3,10 @@ module Tactics { # A record (or frame) on the goal stack has the following form: # |{ # 'goal := , -# 'id := , +# 'id := # 'assumptions := , # 'eigenvariables := , -# 'witnesses := , +# 'witnesses := , # 'parent := # 'children := # }| @@ -16,29 +16,31 @@ module Tactics { define goal-id-counter := (cell 0) - define ht := (HashTable.table 500) - - define root-id := (cell "g1") + define root-goal := (cell ()) define fresh-goal-id := lambda () (join "g" (val->string (inc goal-id-counter))) + define (add-all p assumptions) := + (join assumptions (dedup (get-conjuncts-recursive p))) + define clear-state := lambda () - (seq (HashTable.clear ht) + (seq (set! root-goal (cell ())) (set! goal-id-counter 0)) define set-goal := lambda (goal-sentence) - let {_ := (clear-state); - root := (fresh-goal-id); - _ := (set! root-id root)} - (set! goal-stack [|{'id := root, - 'goal := goal-sentence, - 'assumptions := [], - 'eigenvariables := [], - 'witnesses := [], - 'parent := (cell ()), - 'children := (cell [])}|]) + let {_ := (clear-state); + goal-node := |{'id := (fresh-goal-id), + 'path := [], + 'goal := goal-sentence, + 'assumptions := [], + 'eigenvariables := [], + 'witnesses := [], + 'parent := (), + 'children := (cell [])}|; + _ := (set! root-goal goal-node)} + (set! goal-stack [goal-node]) define (set-parent g1 g2) := # Make g1 the parent of g2 and g2 a child of g1: @@ -49,41 +51,53 @@ define (set-parent g1 g2) := define (set-parent* g1 goal-records) := (map-proc (lambda (g) (set-parent g1 g)) goal-records) -# Apply a given tactic to the topmost goal: +# Apply a given tactic to the top goal: + +define (add-child goal child) := + let {goal-children-cell := (goal 'children); + goal-children := (ref goal-children-cell)} + (set! goal-children-cell (join goal-children [child])) + +define (make-child goal new-child-bindings) := + let {child := (Map.add goal (join [['parent goal] + ['id (fresh-goal-id)] + ['children (cell [])]] + new-child-bindings)); + _ := (add-child goal child)} + child -define (make-new goal-record new-bindings) := - (Map.add goal-record (join [['parent (cell ())] ['id (fresh-goal-id)] ['children (cell [])]] new-bindings)) +define (extend-path goal index) := (join (goal 'path) [index]) +define (make-subgoals goal subgoals) := + let {make-subgoal := lambda (p index) (make-child goal [['goal p] ['path (extend-path goal index)]]); + counter := (cell 1)} + (map lambda (p) (make-subgoal p (inc counter)) + subgoals) + define (backward-tactic goal-stack tactic-name) := match goal-stack { (list-of goal-record rest) => match (goal-record 'goal) { (and (some-list conjuncts)) => - let {make-new-goal-record := lambda (conjunct) (make-new goal-record [['goal conjunct]]); - new-goal-records := (map make-new-goal-record conjuncts); - _ := (set-parent* goal-record new-goal-records); - new-stack := (join new-goal-records rest); - _ := (print "\nNEW STACK: " new-stack)} + let {make-new-goal-record := lambda (conjunct) (make-child goal-record [['goal conjunct]]); + new-goal-records := (make-subgoals goal-record conjuncts); + new-stack := (join new-goal-records rest)} new-stack | (if (some-sentence p) (some-sentence q)) => - let {goal-record' := (make-new goal-record [['goal q] ['assumptions (add p (goal-record 'assumptions))]]); - _ := (set-parent goal-record goal-record')} + let {goal-record' := (make-child goal-record [['goal q] ['assumptions (add-all p (goal-record 'assumptions))]])} (add goal-record' rest) | (iff (some-sentence p) (some-sentence q)) => - let {goal-record' := (make-new goal-record [['goal (and (if p q) (if q p))]]); - _ := (set-parent goal-record goal-record')} + let {goal-record' := (make-child goal-record [['goal (and (if p q) (if q p))]])} (add goal-record' rest) | (or (some-sentence p) (some-sentence q)) => - let {[new-goal new-assumption] := check {(tactic-name equals? 'back-lor) => [p q] | else => [q p]}; - goal-record' := (make-new goal-record [['goal new-goal] ['assumptions (add new-assumption (goal-record 'assumptions))]]); - _ := (set-parent goal-record goal-record')} + let {[new-goal new-assumption] := check {(tactic-name equals? 'back-lor) => [p (not q)] | else => [q (not p)]}; + goal-record' := (make-child goal-record [['goal new-goal] ['assumptions (add-all new-assumption (goal-record 'assumptions))]])} (add goal-record' rest) | _ => goal-stack } | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") } - define tactic-dictionary := |{ 'back-lor := lambda (goal-stack) (backward-tactic goal-stack 'lor), @@ -93,26 +107,38 @@ define tactic-dictionary := 'back-and := lambda (goal-stack) (backward-tactic goal-stack 'back-end), }| -define (apply-tactic tactic-name) := - let {# Retrieve the tactic by name: - tactic := (tactic-dictionary tactic-name); - # Apply the tactic to the goal-stack: - new-stack := (tactic (ref goal-stack))} - (set! goal-stack new-stack) - define (show-goal-record g i N) := - (print "\n*** Stack record #" i " out of " N ":\n--Goal: " (g 'goal) "\n--Goal id: " (g 'id) + (print "\n\n****************************** Stack record" i "out of" N "\n--Goal: " (g 'goal) "\n--Goal id: " (g 'id) "\n--Assumptions:\n" (g 'assumptions) "\n--Eigenvariables: " (g 'eigenvariables) "\n--Witnesses: " (g 'witnesses)) define (show-stack) := - let {counter := (cell 0); + let {counter := (cell 1); N := (length (ref goal-stack))} - (seq (print "\n[[[[[[[[[[[[[\n") + (seq (print "\n[[[[[[[[[[[[[") (map-proc (lambda (r) (show-goal-record r (inc counter) N)) (ref goal-stack)) - (print "\n]]]]]]]]]]]]]")) + (print "\n\n]]]]]]]]]]]]]\n")) + +define (apply-tactic tactic-name) := + let {# Retrieve the tactic by name: + tactic := (tactic-dictionary tactic-name); + # Apply the tactic to the goal-stack: + new-stack := (tactic (ref goal-stack)); + _ := (set! goal-stack new-stack); + _ := (print "\nTactic application successful, new goal stack:\n")} + (show-stack) } # close module Tactics +declare A, B, C, D, E: Boolean + +open Tactics + EOF -load "lib/basic/tactics" \ No newline at end of file + +load "lib/basic/tactics" + +(set-goal (if (and A B) (and B A))) + +(apply-tactic 'back-if) +(apply-tactic 'back-and) \ No newline at end of file From a97c6995568939c4ed6800b4e9d6a7514ff9d5cf Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 14 Oct 2024 15:16:25 -0400 Subject: [PATCH 08/49] Almost done with extraction tactics --- lib/basic/tactics.ath | 277 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 241 insertions(+), 36 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index d2cb347..951ff61 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -1,5 +1,140 @@ module Tactics { +define (flip pol) := + match pol { + 'p => 'n + | 'n => 'p + | 'pn => 'pn} + + define (polarities p q) := + match q { + (val-of p) => ['p] + | (~ q1) => (map flip (polarities p q1)) + | (q1 ==> q2) => (join (map flip (polarities p q1)) + (polarities p q2)) + | (q1 <==> q2) => (map lambda (_) 'pn + (join (polarities p q1) (polarities p q2))) + | ((some-sent-con _) (some-list args)) => + (flatten (map lambda (q) (polarities p q) + args)) + | _ => [] + } + + +define (sub-sentence-map p) := + letrec {loop := lambda (p M pos) + match p { + ((some-sent-con _) (some-list args)) => (loop* args (Map.add M [[pos p]]) pos 1) + | _ => (Map.add M [[pos p]]) + }; + loop* := lambda (props M pos i) + match props { + [] => M + | (list-of p more) => (loop* more (loop p M (join pos [i])) pos (plus i 1)) + }} + (loop p |{}| []) + + +define (extend-map M k v) := + let {res := try { (M k) | [] }} + (Map.add M [[k (add v res)]]) + +# (sub-sentence-map p) returns a dictionary that maps every subsentence q of p +# to a list of pairs of the form [position polarity], where position is a Dewey path +# indicating the position of q in p (viewing p as a tree) and polarity indicates the polarity of q in p. +# A list of such pairs is returned because a single subsentence may have multiple occurrences in p. + +define (sub-sentence-map p) := + letrec {loop := lambda (p pos pol M) + match p { + (~ q) => (loop q (join pos [1]) (flip pol) (extend-map M p [pos pol])) + | (and (some-list args)) => + (loop* args + pos + pol + (extend-map M p [pos pol]) + 1) + | (or (some-list args)) => + (loop* args + pos + pol + (extend-map M p [pos pol]) + 1) + | (if p1 p2) => (loop p2 + (join pos [2]) + pol + (loop p1 + (join pos [1]) + (flip pol) + (extend-map M p [pos pol]))) + | (iff p1 p2) => let {M1 := (loop p1 (join pos [1]) 'pn M); + M2 := (loop p2 (join pos [2]) 'pn M1)} + (extend-map M2 p [pos pol]) + | _ => (extend-map M p [pos pol]) + }; + loop* := lambda (props pos pol M i) + match props { + [] => M + | (list-of p more) => + (loop* more + pos + pol + (loop p (join pos [i]) pol M) + (plus i 1)) + }} + (loop p [] 'p |{}|) + +define (polarities-and-positions p q) := + let {prepend-and-process := + lambda (i f) + lambda (pos-pol-pair) + match pos-pol-pair { + [pos pol] => [(add i pos) (f pol)] + }; + id := lambda (x) x; + make-pos-neg := lambda (_) 'pn} + match q { + (val-of p) => [[[] 'p]] + | (~ q1) => (map (prepend-and-process 1 flip) + (polarities-and-positions p q1)) + | (q1 ==> q2) => (join (map (prepend-and-process 1 flip) + (polarities-and-positions p q1)) + (map (prepend-and-process 2 id) + (polarities-and-positions p q2))) + | (q1 <==> q2) => (join (map (prepend-and-process 1 make-pos-neg) + (polarities-and-positions p q1)) + (map (prepend-and-process 2 make-pos-neg) + (polarities-and-positions p q2))) + | ((some-sent-con _) (some-list args)) => + let {i := (cell 1)} + (flatten (map lambda (q) + (map (prepend-and-process (inc i) id) + (polarities-and-positions p q)) + args)) + | _ => [] + } + +define (find-positive-goal-parent goal premise) := +# Find a positive subsentence of the premise that is a parent of the goal. +# If no such subsentences exists, return (). +# If more than one such subsentence exists, return the first one (in a DFS ordering of all subsentences of the premise). + let {subsentence-map := (sub-sentence-map premise); + parent? := lambda (parent child) + (member? child (children parent)); + complex-non-negation := lambda (p) + (|| (conjunction? p) (disjunction? p) (conditional? p) (biconditional? p)); + positive? := lambda (position-polarity-pair) + (member? (second position-polarity-pair) + ['p 'pn])} + (find-element (Map.keys subsentence-map) + lambda (ss) + (&& (parent? ss goal) + (complex-non-negation ss) + (for-some (subsentence-map ss) positive?)) + lambda (pp) (print "\nHERE'S A POSITIVE PARENT OF THE GIVEN GOAL:" pp) + lambda () ()) + + # A record (or frame) on the goal stack has the following form: # |{ # 'goal := , @@ -21,27 +156,13 @@ module Tactics { define fresh-goal-id := lambda () (join "g" (val->string (inc goal-id-counter))) define (add-all p assumptions) := - (join assumptions (dedup (get-conjuncts-recursive p))) + (join assumptions (dedup (add p (get-conjuncts-recursive p)))) define clear-state := lambda () (seq (set! root-goal (cell ())) (set! goal-id-counter 0)) -define set-goal := - lambda (goal-sentence) - let {_ := (clear-state); - goal-node := |{'id := (fresh-goal-id), - 'path := [], - 'goal := goal-sentence, - 'assumptions := [], - 'eigenvariables := [], - 'witnesses := [], - 'parent := (), - 'children := (cell [])}|; - _ := (set! root-goal goal-node)} - (set! goal-stack [goal-node]) - define (set-parent g1 g2) := # Make g1 the parent of g2 and g2 a child of g1: let {_ := (set! (g1 'children) @@ -57,17 +178,18 @@ define (add-child goal child) := let {goal-children-cell := (goal 'children); goal-children := (ref goal-children-cell)} (set! goal-children-cell (join goal-children [child])) - + +define (extend-path goal index) := (join (goal 'path) [index]) + define (make-child goal new-child-bindings) := let {child := (Map.add goal (join [['parent goal] + ['path (extend-path goal 1)] ['id (fresh-goal-id)] ['children (cell [])]] new-child-bindings)); _ := (add-child goal child)} child -define (extend-path goal index) := (join (goal 'path) [index]) - define (make-subgoals goal subgoals) := let {make-subgoal := lambda (p index) (make-child goal [['goal p] ['path (extend-path goal index)]]); counter := (cell 1)} @@ -97,18 +219,10 @@ define (backward-tactic goal-stack tactic-name) := } | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") } - -define tactic-dictionary := - |{ - 'back-lor := lambda (goal-stack) (backward-tactic goal-stack 'lor), - 'back-ror := lambda (goal-stack) (backward-tactic goal-stack 'back-ror), - 'back-if := lambda (goal-stack) (backward-tactic goal-stack 'back-if), - 'back-iff := lambda (goal-stack) (backward-tactic goal-stack 'back-iff), - 'back-and := lambda (goal-stack) (backward-tactic goal-stack 'back-end), - }| define (show-goal-record g i N) := - (print "\n\n****************************** Stack record" i "out of" N "\n--Goal: " (g 'goal) "\n--Goal id: " (g 'id) + (print "\n\n****************************** Stack record" i "out of" N "\n--Goal: " (g 'goal) + "\n--Goal id: " (g 'id) "\n--Path: " (g 'path) "\n--Assumptions:\n" (g 'assumptions) "\n--Eigenvariables: " (g 'eigenvariables) "\n--Witnesses: " (g 'witnesses)) define (show-stack) := @@ -119,15 +233,103 @@ define (show-stack) := (ref goal-stack)) (print "\n\n]]]]]]]]]]]]]\n")) -define (apply-tactic tactic-name) := +define set-goal := + lambda (goal-sentence) + check {(holds? goal-sentence) => (print "\nThis sentence already holds.") + | else => let {_ := (clear-state); + goal-node := |{'id := (fresh-goal-id), + 'path := [], + 'goal := goal-sentence, + 'assumptions := [], + 'eigenvariables := [], + 'witnesses := [], + 'parent := (), + 'children := (cell [])}|; + _ := (set! root-goal goal-node); + _ := (set! goal-stack [goal-node]); + _ := (print "\nCreated a new goal stack:\n")} + (show-stack) + } + + +define extraction-tactic := + lambda (goal-stack args) + match goal-stack { + (list-of goal-record rest) => + match [ (goal-record 'goal) args] { + # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: + [goal [premise]] => check {(negate (|| (member? premise (goal-record 'assumptions)) + (holds? premise))) => (error "Invalid application of the extraction tactic: the given premise does not hold:\n" premise) + | else => match (find-positive-goal-parent goal premise) { + () => (error "Invalid application of the extraction tactic: the given premise does not have any positive occurrences of a parent of the given goal") + | (some-sentence parent) => let {goal-record' := (make-child goal-record [['goal parent]])} + (add goal-record' rest) + }} + } + } + +define tactic-dictionary := + |{ + 'back-lor := lambda (goal-stack _) (backward-tactic goal-stack 'lor), + 'back-ror := lambda (goal-stack _) (backward-tactic goal-stack 'back-ror), + 'back-if := lambda (goal-stack _) (backward-tactic goal-stack 'back-if), + 'back-iff := lambda (goal-stack _) (backward-tactic goal-stack 'back-iff), + 'back-and := lambda (goal-stack _) (backward-tactic goal-stack 'back-and), + 'extract := extraction-tactic, + 'back := lambda (goal-stack _) + match goal-stack { + (list-of goal-record _) => + match (goal-record 'goal) { + (and (some-list _)) => (backward-tactic goal-stack 'back-and) + | (or (some-list _)) => (backward-tactic goal-stack 'lor) + | (if _ _) => (backward-tactic goal-stack 'back-if) + | (iff _ _) => (backward-tactic goal-stack 'back-iff) + | _ => goal-stack + } + | _ => goal-stack + }, + 'claim := lambda (goal-stack _) + match goal-stack { + (list-of goal-record rest) => + let {goal := (goal-record 'goal)} + check {(|| (holds? goal) (member? goal (goal-record 'assumptions))) => rest + | else => (error "Incorrect application of 'claim tactic--the top goal does not hold.")} + | _ => goal-stack + } + }| + + +define done? := lambda () (null? (ref goal-stack)) + +define (apply-tactic tactic-name args) := let {# Retrieve the tactic by name: tactic := (tactic-dictionary tactic-name); # Apply the tactic to the goal-stack: - new-stack := (tactic (ref goal-stack)); - _ := (set! goal-stack new-stack); - _ := (print "\nTactic application successful, new goal stack:\n")} - (show-stack) - + new-stack := (try (tactic (ref goal-stack) args) 'error)} + match new-stack { + 'error => 'error + | _ => let {_ := (set! goal-stack new-stack); + _ := (print "\nApplied tactic" (val->string tactic-name) "successfully.\n"); + _ := check {(done?) => (print "\nGoal completely proven!") + | else => (seq (print "\nHere's the new goal stack:\n") + (show-stack) + (print "\nWill now try to apply the claim tactic...\n") + (apply-tactic 'claim [])) + } + } + 'success + } + +define (apply-tactic* tactic-name args) := +## As long as it can be successfully applied and we are not completely done, keep applying the given tactic. + match (apply-tactic tactic-name args) { + 'success => check {(done?) => () + | else => (apply-tactic* tactic-name args)} + | _ => () + } + + + } # close module Tactics declare A, B, C, D, E: Boolean @@ -140,5 +342,8 @@ load "lib/basic/tactics" (set-goal (if (and A B) (and B A))) -(apply-tactic 'back-if) -(apply-tactic 'back-and) \ No newline at end of file +(apply-tactic 'back []) + +(apply-tactic* 'back []) + +(apply-tactic 'back-and []) \ No newline at end of file From 1c23f21a3d9e35858ddef4f934f0fe957fce9028 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 14 Oct 2024 16:10:43 -0400 Subject: [PATCH 09/49] WIP --- lib/basic/tactics.ath | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 951ff61..63a1175 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -143,7 +143,8 @@ define (find-positive-goal-parent goal premise) := # 'eigenvariables := , # 'witnesses := , # 'parent := -# 'children := +# 'children := +# 'tactic := ] used to obtain the children goals> # }| @@ -163,15 +164,6 @@ define (find-positive-goal-parent goal premise) := (seq (set! root-goal (cell ())) (set! goal-id-counter 0)) -define (set-parent g1 g2) := -# Make g1 the parent of g2 and g2 a child of g1: - let {_ := (set! (g1 'children) - (join (ref (g1 'children)) [g2]))} - (seq (set! (g2 'parent) g1)) - -define (set-parent* g1 goal-records) := - (map-proc (lambda (g) (set-parent g1 g)) goal-records) - # Apply a given tactic to the top goal: define (add-child goal child) := @@ -197,11 +189,13 @@ define (make-subgoals goal subgoals) := subgoals) define (backward-tactic goal-stack tactic-name) := +# This essentially ignores tactic-name for all cases except disjunctions. What if a tactic like 'back-and is applied to a conditional? match goal-stack { (list-of goal-record rest) => + let {_ := (set! (goal-record 'tactic) [tactic-name []])} match (goal-record 'goal) { (and (some-list conjuncts)) => - let {make-new-goal-record := lambda (conjunct) (make-child goal-record [['goal conjunct]]); + let {make-new-goal-record := lambda (conjunct) (make-child goal-record [['goal conjunct]]); new-goal-records := (make-subgoals goal-record conjuncts); new-stack := (join new-goal-records rest)} new-stack @@ -244,6 +238,7 @@ define set-goal := 'eigenvariables := [], 'witnesses := [], 'parent := (), + 'tactic := (cell ()), 'children := (cell [])}|; _ := (set! root-goal goal-node); _ := (set! goal-stack [goal-node]); @@ -251,6 +246,11 @@ define set-goal := (show-stack) } +define (proper-extraction-tactic goal premise parent) := +# This will produce a pair of the form [ args] where +# is a meta-identifier representing a proper (fully specified) extraction tactic name, and args is the list +# of all those values that are necessary for the tactic to work. qqq IMPLEMENT THIS FUNCTION + () define extraction-tactic := lambda (goal-stack args) @@ -262,7 +262,8 @@ define extraction-tactic := (holds? premise))) => (error "Invalid application of the extraction tactic: the given premise does not hold:\n" premise) | else => match (find-positive-goal-parent goal premise) { () => (error "Invalid application of the extraction tactic: the given premise does not have any positive occurrences of a parent of the given goal") - | (some-sentence parent) => let {goal-record' := (make-child goal-record [['goal parent]])} + | (some-sentence parent) => let {goal-record' := (make-child goal-record [['goal parent]]); + _ := (set! (goal-record 'tactic) (proper-extraction-tactic goal premise parent))} (add goal-record' rest) }} } From 8ce82cf49d86cf08634e72a5ffdc71e6c6b28381 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Tue, 15 Oct 2024 13:30:41 -0400 Subject: [PATCH 10/49] Tree-based representations of the search --- lib/basic/tactics.ath | 145 ++++++++++++++++++++++++++++++++++-------- 1 file changed, 117 insertions(+), 28 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 63a1175..180adfd 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -115,7 +115,7 @@ define (polarities-and-positions p q) := } define (find-positive-goal-parent goal premise) := -# Find a positive subsentence of the premise that is a parent of the goal. +# Find a positive subsentence of the premise, call it p, that is a parent of the goal. Return a pair of p and the position of p in premise. # If no such subsentences exists, return (). # If more than one such subsentence exists, return the first one (in a DFS ordering of all subsentences of the premise). let {subsentence-map := (sub-sentence-map premise); @@ -126,24 +126,26 @@ define (find-positive-goal-parent goal premise) := positive? := lambda (position-polarity-pair) (member? (second position-polarity-pair) ['p 'pn])} - (find-element (Map.keys subsentence-map) - lambda (ss) - (&& (parent? ss goal) - (complex-non-negation ss) - (for-some (subsentence-map ss) positive?)) - lambda (pp) (print "\nHERE'S A POSITIVE PARENT OF THE GIVEN GOAL:" pp) - lambda () ()) + (find-element' (Map.keys subsentence-map) + lambda (ss-pos-pair) + let {[ss pos] := ss-pos-pair} + (&& (parent? ss goal) + (complex-non-negation ss) + (for-some (subsentence-map ss) positive?)) + lambda (ss) [ss (first (first (subsentence-map ss)))] + lambda (ss-pair) ss-pair + lambda () ()) - # A record (or frame) on the goal stack has the following form: # |{ # 'goal := , -# 'id := +# 'id := , +# 'path := , # 'assumptions := , # 'eigenvariables := , # 'witnesses := , -# 'parent := -# 'children := +# 'parent := , +# 'children := , # 'tactic := ] used to obtain the children goals> # }| @@ -173,11 +175,15 @@ define (add-child goal child) := define (extend-path goal index) := (join (goal 'path) [index]) +define (make-new-goal starting-goal bindings) := + (Map.add starting-goal bindings) + define (make-child goal new-child-bindings) := let {child := (Map.add goal (join [['parent goal] ['path (extend-path goal 1)] ['id (fresh-goal-id)] - ['children (cell [])]] + ['children (cell [])] + ['tactic (cell [])]] new-child-bindings)); _ := (add-child goal child)} child @@ -246,25 +252,57 @@ define set-goal := (show-stack) } -define (proper-extraction-tactic goal premise parent) := -# This will produce a pair of the form [ args] where -# is a meta-identifier representing a proper (fully specified) extraction tactic name, and args is the list -# of all those values that are necessary for the tactic to work. qqq IMPLEMENT THIS FUNCTION - () +define (proper-extraction-tactic goal premise parent parent-position-in-premise) := +# This will produce a dictionary of the form +# |{ +# 'tactic-info := [ args], +# 'subgoals := +# }| +# +# where is a meta-identifier representing a proper (fully specified) extraction +# tactic name, and args is the list of all those values that are necessary for the tactic to work. + let {aux-info := [premise parent parent-position-in-premise]} + match parent { + + ((and (some-list props)) where (member? goal props)) => |{'tactic-info := ['and-> aux-info], 'subgoals := [parent]}| + + | ((or (some-list props)) where (member? goal props)) => |{'tactic-info := ['or-> aux-info], + 'subgoals := (add parent + (map-select-2 lambda (disjunct) + (if disjunct goal) + props + lambda (disjunct) + (unequal? disjunct goal)))}| + + | (if antecedent (val-of goal)) => |{'tactic-info := ['if-> aux-info], 'subgoals := [parent antecedent]}| + + | (iff left (val-of goal)) => |{'tactic-info := ['iff-left-> aux-info], 'subgoals := [parent left]}| + + | (iff (val-of goal) right) => |{'tactic-info := ['iff-right-> aux-info], 'subgoals := [parent right]}| + + } define extraction-tactic := lambda (goal-stack args) + # We must return a new goal stack. + let {_ := (print "\nInside the extraction tactic, here's args: " args "\nand here is the goal stack: " goal-stack)} match goal-stack { (list-of goal-record rest) => - match [ (goal-record 'goal) args] { + match [(goal-record 'goal) args] { # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: [goal [premise]] => check {(negate (|| (member? premise (goal-record 'assumptions)) (holds? premise))) => (error "Invalid application of the extraction tactic: the given premise does not hold:\n" premise) | else => match (find-positive-goal-parent goal premise) { - () => (error "Invalid application of the extraction tactic: the given premise does not have any positive occurrences of a parent of the given goal") - | (some-sentence parent) => let {goal-record' := (make-child goal-record [['goal parent]]); - _ := (set! (goal-record 'tactic) (proper-extraction-tactic goal premise parent))} - (add goal-record' rest) + () => (error "Invalid application of the extraction tactic: the given premise does not have any positive occurrences of a goal parent") + | [(some-sentence parent) position] => + let { D := (proper-extraction-tactic goal premise parent position); + [tactic-info subgoals] := [(D 'tactic-info) (D 'subgoals)]; + _ := (set! (goal-record 'tactic) tactic-info); + counter := (cell 1); + new-goal-records' := (map lambda (subgoal) (make-child goal-record [['goal subgoal] ['path (extend-path goal-record (inc counter))]]) + subgoals) + } + (join new-goal-records' rest) }} } } @@ -292,9 +330,15 @@ define tactic-dictionary := 'claim := lambda (goal-stack _) match goal-stack { (list-of goal-record rest) => - let {goal := (goal-record 'goal)} - check {(|| (holds? goal) (member? goal (goal-record 'assumptions))) => rest - | else => (error "Incorrect application of 'claim tactic--the top goal does not hold.")} + let {goal := (goal-record 'goal); + cond1 := (holds? goal); + cond2 := (member? goal (goal-record 'assumptions)); + _ := (print "\nWe'll try to claim this goal:" goal ". Does it hold?: " cond1 ". Is it in the assumptions?: " cond2) + } + check {(|| cond1 cond2) => + let {_ := (set! (goal-record 'tactic) ['claim []])} + rest + | else => let {_ := (print "\nNO DICE...\n")} (error "Incorrect application of 'claim tactic--the top goal does not hold.")} | _ => goal-stack } }| @@ -305,8 +349,9 @@ define done? := lambda () (null? (ref goal-stack)) define (apply-tactic tactic-name args) := let {# Retrieve the tactic by name: tactic := (tactic-dictionary tactic-name); + _ := (print "\nGot the tactic, and here's the args: " args); # Apply the tactic to the goal-stack: - new-stack := (try (tactic (ref goal-stack) args) 'error)} + new-stack := (try (tactic (ref goal-stack) args) 'error)} match new-stack { 'error => 'error | _ => let {_ := (set! goal-stack new-stack); @@ -330,6 +375,39 @@ define (apply-tactic* tactic-name args) := } +define (spaces n) := + check {(n less? 1) => "" + | else => (join " " (spaces (n minus 1)))} + +define (stringify v) := + letrec {loop := lambda (chars so-far) + match chars { + [] => (rev so-far) + | (list-of c more) => check {(c equals? `\n) => (loop more so-far) + | (&& (c equals? `\032) (negate (null? so-far)) (equals? (first so-far) `\032)) => (loop more so-far) + | else => (loop more (add c so-far))} + }} + (loop (val->string v) []) + + + +define (show-tree) := + let {start := (ref root-goal)} + letrec {display-goal-record := lambda (goal-record level) + let {goal := (goal-record 'goal); + _ := (print "\n" (spaces level) (stringify (goal-record 'path)) + "Goal:" (stringify goal) + "Assumptions:" (stringify (goal-record 'assumptions)) + "Tactic:" (stringify (ref (goal-record 'tactic))))} + (display-goal-records (ref (goal-record 'children)) (plus level 2)); + display-goal-records := lambda (goal-records level) + match goal-records { + [] => () + | (list-of goal-record more) => let {_ := (display-goal-record goal-record level)} + (display-goal-records more level) + }} + (display-goal-record start 0) + } # close module Tactics @@ -343,8 +421,19 @@ load "lib/basic/tactics" (set-goal (if (and A B) (and B A))) +define p := (and (not A) (not not A) (iff (A & B) (B & A)) (not not A));; + +(find-positive-goal-parent A p) + (apply-tactic 'back []) (apply-tactic* 'back []) -(apply-tactic 'back-and []) \ No newline at end of file +(apply-tactic 'back-and []) + + +define [p1 p2] := [(A ==> B & C) (A & E)] +assert [p1 p2] +(set-goal C) +(apply-tactic 'extract [p1]) +(apply-tactic 'extract [p1]) \ No newline at end of file From 0ddd5a843b4537c3d91feba47fa5cb19d5e3b9cd Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Tue, 15 Oct 2024 14:06:27 -0400 Subject: [PATCH 11/49] Marking leaves --- lib/basic/tactics.ath | 88 +++++++++++++++++++++++++------------------ 1 file changed, 52 insertions(+), 36 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 180adfd..72fd835 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -261,7 +261,7 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise) # # where is a meta-identifier representing a proper (fully specified) extraction # tactic name, and args is the list of all those values that are necessary for the tactic to work. - let {aux-info := [premise parent parent-position-in-premise]} + let {aux-info := |{'premise := premise, 'goal-parent := parent, 'parent-position-in-premise := parent-position-in-premise}|} match parent { ((and (some-list props)) where (member? goal props)) => |{'tactic-info := ['and-> aux-info], 'subgoals := [parent]}| @@ -344,6 +344,50 @@ define tactic-dictionary := }| +define (spaces n) := + check {(n less? 1) => "" + | else => (join " " (spaces (n minus 1)))} + +define (stringify v) := + letrec {loop := lambda (chars so-far) + match chars { + [] => (rev so-far) + | (list-of c more) => check {(c equals? `\n) => (loop more so-far) + | (&& (c equals? `\032) (negate (null? so-far)) (equals? (first so-far) `\032)) => (loop more so-far) + | else => (loop more (add c so-far))} + }} + (loop (val->string v) []) + + +define (tac->string tac) := + match tac { + [tactic-name tactic-info] => + check {(tactic-name equals? 'claim) => "'claim ** LEAF **" + | else => (stringify tac)} + | _ => (stringify tac) + } + +define (show-tree current-goal-id) := + let {start := (ref root-goal)} + letrec {display-goal-record := lambda (goal-record level) + let {goal := (goal-record 'goal); + goal-id := (goal-record 'id); + is-current := (equals? goal-id current-goal-id); + goal-line := check {(equals? goal-id current-goal-id) => (join "---> Goal: " (stringify goal)) + | else => (join "Goal: " (stringify goal))}; + _ := (print "\n" (spaces level) (stringify (goal-record 'path)) + goal-line + "Assumptions:" (stringify (goal-record 'assumptions)) + "Tactic:" (tac->string (ref (goal-record 'tactic))))} + (display-goal-records (ref (goal-record 'children)) (plus level 2)); + display-goal-records := lambda (goal-records level) + match goal-records { + [] => () + | (list-of goal-record more) => let {_ := (display-goal-record goal-record level)} + (display-goal-records more level) + }} + (display-goal-record start 0) + define done? := lambda () (null? (ref goal-stack)) define (apply-tactic tactic-name args) := @@ -356,11 +400,15 @@ define (apply-tactic tactic-name args) := 'error => 'error | _ => let {_ := (set! goal-stack new-stack); _ := (print "\nApplied tactic" (val->string tactic-name) "successfully.\n"); + current-goal-id := check {(null? new-stack) => () + | else => ((first new-stack) 'id)}; _ := check {(done?) => (print "\nGoal completely proven!") | else => (seq (print "\nHere's the new goal stack:\n") (show-stack) (print "\nWill now try to apply the claim tactic...\n") - (apply-tactic 'claim [])) + (apply-tactic 'claim []) + (print "\nAnd the new search tree:\n") + (show-tree current-goal-id)) } } 'success @@ -375,39 +423,6 @@ define (apply-tactic* tactic-name args) := } -define (spaces n) := - check {(n less? 1) => "" - | else => (join " " (spaces (n minus 1)))} - -define (stringify v) := - letrec {loop := lambda (chars so-far) - match chars { - [] => (rev so-far) - | (list-of c more) => check {(c equals? `\n) => (loop more so-far) - | (&& (c equals? `\032) (negate (null? so-far)) (equals? (first so-far) `\032)) => (loop more so-far) - | else => (loop more (add c so-far))} - }} - (loop (val->string v) []) - - - -define (show-tree) := - let {start := (ref root-goal)} - letrec {display-goal-record := lambda (goal-record level) - let {goal := (goal-record 'goal); - _ := (print "\n" (spaces level) (stringify (goal-record 'path)) - "Goal:" (stringify goal) - "Assumptions:" (stringify (goal-record 'assumptions)) - "Tactic:" (stringify (ref (goal-record 'tactic))))} - (display-goal-records (ref (goal-record 'children)) (plus level 2)); - display-goal-records := lambda (goal-records level) - match goal-records { - [] => () - | (list-of goal-record more) => let {_ := (display-goal-record goal-record level)} - (display-goal-records more level) - }} - (display-goal-record start 0) - } # close module Tactics @@ -436,4 +451,5 @@ define [p1 p2] := [(A ==> B & C) (A & E)] assert [p1 p2] (set-goal C) (apply-tactic 'extract [p1]) -(apply-tactic 'extract [p1]) \ No newline at end of file +(apply-tactic 'extract [p1]) +(apply-tactic 'extract [p2]) \ No newline at end of file From 4aa4497be70980bafa50f7b5e55db0f465abd026 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Thu, 17 Oct 2024 12:27:04 -0400 Subject: [PATCH 12/49] Implemented infer, contradiction, and from-complements tactics --- lib/basic/tactics.ath | 119 ++++++++++++++++++++++++++++++++++++++---- 1 file changed, 109 insertions(+), 10 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 72fd835..12b01f0 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -20,6 +20,9 @@ define (flip pol) := | _ => [] } +define (silence-on) := (process-input-from-string "(set-flag silent-mode \"on\")") +define (silence-off) := (process-input-from-string "(set-flag silent-mode \"off\")") +define (merror str) := let {_ := (print "\nMERRORRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRR" str "\n")} (error str) define (sub-sentence-map p) := letrec {loop := lambda (p M pos) @@ -168,8 +171,8 @@ define (find-positive-goal-parent goal premise) := # Apply a given tactic to the top goal: -define (add-child goal child) := - let {goal-children-cell := (goal 'children); +define (add-child goal-record child) := + let {goal-children-cell := (goal-record 'children); goal-children := (ref goal-children-cell)} (set! goal-children-cell (join goal-children [child])) @@ -178,14 +181,14 @@ define (extend-path goal index) := (join (goal 'path) [index]) define (make-new-goal starting-goal bindings) := (Map.add starting-goal bindings) -define (make-child goal new-child-bindings) := - let {child := (Map.add goal (join [['parent goal] - ['path (extend-path goal 1)] - ['id (fresh-goal-id)] - ['children (cell [])] - ['tactic (cell [])]] - new-child-bindings)); - _ := (add-child goal child)} +define (make-child goal-record new-child-bindings) := + let {child := (Map.add goal-record (join [['parent goal-record] + ['path (extend-path goal-record 1)] + ['id (fresh-goal-id)] + ['children (cell [])] + ['tactic (cell [])]] + new-child-bindings)); + _ := (add-child goal-record child)} child define (make-subgoals goal subgoals) := @@ -307,6 +310,91 @@ define extraction-tactic := } } +define contradiction-tactic := + lambda (goal-stack _) + # We must return a new goal stack. + match goal-stack { + (list-of goal-record rest) => + let {goal := (goal-record 'goal); + _ := (set! (goal-record 'tactic) |{'tactic-info := ['contradiction []], 'subgoals := [false]}|); + new-goal-record := (make-child goal-record [['assumptions (add-all (complement goal) (goal-record 'assumptions))] ['goal false]])} + (add new-goal-record rest) + | _ => (error "Invalid tactic application - there are no open goals currently.") + } + +define (holds-in p goal-record) := + (|| (holds? p) (member? p (goal-record 'assumptions))) + +define (hold-in props goal-record) := (for-each props lambda (p) (holds-in p goal-record)) + +define from-complements-tactic := + lambda (goal-stack args) + # We must return a new goal stack. + let {_ := (print "\nInside the from-complements tactic, here's args: " args "\nand here is the goal stack: " goal-stack)} + match goal-stack { + (list-of goal-record rest) => + match [(goal-record 'goal) args] { + # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: + [_ [complement-1 complement-2]] => + check {(hold-in [complement-1 complement-2] goal-record) => + let {_ := (mark `1); + _ := (set! (goal-record 'tactic) |{'tactic-info := ['from-complements [complement-1 complement-2]], 'subgoals := [], 'leaf := true}|)} + rest + | else => (merror "Incorrect application of 'from-complements, at least one of the given complements does not hold.")} + | _ => (print "Invalid information given to the tactic from-complements: exactly two sentences are required, each a complement of the other.") + } + | _ => (merror "Invalid tactic application - there are no open goals currently.") + } + +define (assert-all props) := + let {c := (cell []); + _ := (print "\nAbout to assert-all these assumptions: " props); + #_ := (silence-on); + _ := (map-proc lambda (p) let {_ := check {(holds? p) => () | else => (set! c (add p (ref c)))}; + cmd := (join "(assert " (val->string p) ")"); + _ := (print "\nCMD to execute: " cmd "\n") + } + (process-input-from-string cmd) + props); + _ := (map-proc (lambda (p) check {(holds? p) => (print "\nYES," p "holds...") | else => (print "\nNO, " p " STILL DOES NOT HOLD...")}) props); + _ := (silence-off)} + (ref c) + +define (retract-all props) := + let {_ := (silence-on); + _ := (map-proc lambda (p) (process-input-from-string (join "(retract " (val->string p) ")")) + props)} + (silence-off) + +define (execute-thunk M assumptions) := + let {#assumptions-not-already-in-ab := (assert-all assumptions); + #_ := (print "\nAB NOW: " (ab)); + p := assume (and assumptions) (!M); + #_ := (print "\nTHUNK RESULT: " p); + #_ := (retract-all assumptions-not-already-in-ab) + _ := () + } + (consequent p) + +define infer-tactic := + lambda (goal-stack args) + # We must return a new goal stack. + match goal-stack { + (list-of goal-record rest) => + match args { + [(some-method M)] => + let {_ := (print "\nINSIDE INFER-TACTIC..."); + lemma := (execute-thunk M (goal-record 'assumptions)); + _ := (print "\nGOT THIS LEMMA: " lemma); + new-goal := (make-child goal-record [['assumptions (add-all lemma (goal-record 'assumptions))]]); + _ := (set! (goal-record 'tactic) |{'tactic-info := ['infer args], 'subgoals := []}|)} + (add new-goal rest) + | _ => (print "Invalid argument given to the infer tactic: A nullary method is expected.") + } + | _ => (error "Invalid tactic application - there are no open goals currently.") + } + + define tactic-dictionary := |{ 'back-lor := lambda (goal-stack _) (backward-tactic goal-stack 'lor), @@ -315,6 +403,9 @@ define tactic-dictionary := 'back-iff := lambda (goal-stack _) (backward-tactic goal-stack 'back-iff), 'back-and := lambda (goal-stack _) (backward-tactic goal-stack 'back-and), 'extract := extraction-tactic, + 'infer := infer-tactic, + 'contradiction := contradiction-tactic, + 'from-complements := from-complements-tactic, 'back := lambda (goal-stack _) match goal-stack { (list-of goal-record _) => @@ -433,6 +524,13 @@ open Tactics EOF load "lib/basic/tactics" +assert p1 := (A ==> B & C) +assert p2 := (~ B) +(set-goal (not A)) +(apply-tactic 'contradiction []) +(apply-tactic 'infer [(method () (!mp p1 A))]) +(apply-tactic 'from-complements [B p2]) + (set-goal (if (and A B) (and B A))) @@ -447,6 +545,7 @@ define p := (and (not A) (not not A) (iff (A & B) (B & A)) (not not A));; (apply-tactic 'back-and []) + define [p1 p2] := [(A ==> B & C) (A & E)] assert [p1 p2] (set-goal C) From 463cae6217397e2fa4e1d497005a3eef2dce6f0a Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Thu, 17 Oct 2024 18:13:06 -0400 Subject: [PATCH 13/49] WIP --- lib/basic/tactics.ath | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 12b01f0..9a181ac 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -186,11 +186,15 @@ define (make-child goal-record new-child-bindings) := ['path (extend-path goal-record 1)] ['id (fresh-goal-id)] ['children (cell [])] + ['proof (cell "")] ['tactic (cell [])]] new-child-bindings)); _ := (add-child goal-record child)} child + +define (leaf? goal-record) := (&& (null? (ref (goal-record 'children))) (unequal? (ref (goal-record 'tactic)) [])) + define (make-subgoals goal subgoals) := let {make-subgoal := lambda (p index) (make-child goal [['goal p] ['path (extend-path goal index)]]); counter := (cell 1)} @@ -247,7 +251,7 @@ define set-goal := 'eigenvariables := [], 'witnesses := [], 'parent := (), - 'tactic := (cell ()), + 'tactic := (cell []), 'children := (cell [])}|; _ := (set! root-goal goal-node); _ := (set! goal-stack [goal-node]); @@ -316,7 +320,7 @@ define contradiction-tactic := match goal-stack { (list-of goal-record rest) => let {goal := (goal-record 'goal); - _ := (set! (goal-record 'tactic) |{'tactic-info := ['contradiction []], 'subgoals := [false]}|); + _ := (set! (goal-record 'tactic) ['contradiction []]); new-goal-record := (make-child goal-record [['assumptions (add-all (complement goal) (goal-record 'assumptions))] ['goal false]])} (add new-goal-record rest) | _ => (error "Invalid tactic application - there are no open goals currently.") @@ -338,7 +342,7 @@ define from-complements-tactic := [_ [complement-1 complement-2]] => check {(hold-in [complement-1 complement-2] goal-record) => let {_ := (mark `1); - _ := (set! (goal-record 'tactic) |{'tactic-info := ['from-complements [complement-1 complement-2]], 'subgoals := [], 'leaf := true}|)} + _ := (set! (goal-record 'tactic) ['from-complements [complement-1 complement-2]])} rest | else => (merror "Incorrect application of 'from-complements, at least one of the given complements does not hold.")} | _ => (print "Invalid information given to the tactic from-complements: exactly two sentences are required, each a complement of the other.") @@ -387,7 +391,7 @@ define infer-tactic := lemma := (execute-thunk M (goal-record 'assumptions)); _ := (print "\nGOT THIS LEMMA: " lemma); new-goal := (make-child goal-record [['assumptions (add-all lemma (goal-record 'assumptions))]]); - _ := (set! (goal-record 'tactic) |{'tactic-info := ['infer args], 'subgoals := []}|)} + _ := (set! (goal-record 'tactic) ['infer args])} (add new-goal rest) | _ => (print "Invalid argument given to the infer tactic: A nullary method is expected.") } @@ -453,23 +457,28 @@ define (stringify v) := define (tac->string tac) := match tac { [tactic-name tactic-info] => - check {(tactic-name equals? 'claim) => "'claim ** LEAF **" + check {(tactic-name equals? 'claim) => "'claim " | else => (stringify tac)} | _ => (stringify tac) } -define (show-tree current-goal-id) := - let {start := (ref root-goal)} +define (show-tree) := + let {start := (ref root-goal); + current-stack := (ref goal-stack); + current-goal-id := check {(null? current-stack) => () + | else => ((first current-stack) 'id)}} letrec {display-goal-record := lambda (goal-record level) let {goal := (goal-record 'goal); goal-id := (goal-record 'id); + leaf-suffix := check {(leaf? goal-record) => " ** LEAF **" + | else => ""}; is-current := (equals? goal-id current-goal-id); goal-line := check {(equals? goal-id current-goal-id) => (join "---> Goal: " (stringify goal)) | else => (join "Goal: " (stringify goal))}; _ := (print "\n" (spaces level) (stringify (goal-record 'path)) goal-line "Assumptions:" (stringify (goal-record 'assumptions)) - "Tactic:" (tac->string (ref (goal-record 'tactic))))} + "Tactic:" (join (tac->string (ref (goal-record 'tactic))) leaf-suffix))} (display-goal-records (ref (goal-record 'children)) (plus level 2)); display-goal-records := lambda (goal-records level) match goal-records { @@ -491,15 +500,13 @@ define (apply-tactic tactic-name args) := 'error => 'error | _ => let {_ := (set! goal-stack new-stack); _ := (print "\nApplied tactic" (val->string tactic-name) "successfully.\n"); - current-goal-id := check {(null? new-stack) => () - | else => ((first new-stack) 'id)}; _ := check {(done?) => (print "\nGoal completely proven!") | else => (seq (print "\nHere's the new goal stack:\n") (show-stack) (print "\nWill now try to apply the claim tactic...\n") (apply-tactic 'claim []) (print "\nAnd the new search tree:\n") - (show-tree current-goal-id)) + (show-tree)) } } 'success From c7a7e1d26f15d52bbd5e193facc117206037c8dd Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Thu, 17 Oct 2024 22:17:40 -0400 Subject: [PATCH 14/49] First draft of final proofs --- lib/basic/tactics.ath | 51 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 44 insertions(+), 7 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 9a181ac..a7dcb68 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -149,7 +149,8 @@ define (find-positive-goal-parent goal premise) := # 'witnesses := , # 'parent := , # 'children := , -# 'tactic := ] used to obtain the children goals> +# 'tactic := ] used to obtain the children goals> +# 'proof := h # }| @@ -210,17 +211,35 @@ define (backward-tactic goal-stack tactic-name) := (and (some-list conjuncts)) => let {make-new-goal-record := lambda (conjunct) (make-child goal-record [['goal conjunct]]); new-goal-records := (make-subgoals goal-record conjuncts); - new-stack := (join new-goal-records rest)} + new-stack := (join new-goal-records rest); + proof-chunks := check {(equal? (length new-goal-records) 2) => ["(!both " "**" " " "**" ")"] + | else => (join ["(!conj-intro "] (separate (map (lambda (_) "**") conjuncts) " ") [")"])}; + _ := (set! (goal-record 'proof) proof-chunks)} new-stack | (if (some-sentence p) (some-sentence q)) => - let {goal-record' := (make-child goal-record [['goal q] ['assumptions (add-all p (goal-record 'assumptions))]])} + let {goal-record' := (make-child goal-record [['goal q] ['assumptions (add-all p (goal-record 'assumptions))]]); + proof-chunks := [(join "assume " (val->string p) "\n ") + "**"]; + _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | (iff (some-sentence p) (some-sentence q)) => - let {goal-record' := (make-child goal-record [['goal (and (if p q) (if q p))]])} + let {goal-record' := (make-child goal-record [['goal (and (if p q) (if q p))]]); + proof-chunks := ["let {biconditional := " "**" "}\n (!equiv (!left-and biconditional) (!right-and biconditional))"]; + _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | (or (some-sentence p) (some-sentence q)) => let {[new-goal new-assumption] := check {(tactic-name equals? 'back-lor) => [p (not q)] | else => [q (not p)]}; - goal-record' := (make-child goal-record [['goal new-goal] ['assumptions (add-all new-assumption (goal-record 'assumptions))]])} + goal-record' := (make-child goal-record [['goal new-goal] ['assumptions (add-all new-assumption (goal-record 'assumptions))]]); + [p-str q-str] := [(val->string p) (val->string q)]; + proof-chunks := check {(tactic-name equals? 'back-lor) => + ["(!two-cases \n assume " q-str "\n (!right-either " p-str " " q-str ")\n " + "\n assume (~ " q-str ")\n let {_ := conclude " p-str "\n " + "**" "}\n (!left-either " p-str " " q-str "))"] + | else => + ["(!two-cases \n assume " p-str "\n (!left-either " p-str " " q-str ")\n " + "\n assume (~ " p-str ")\n let {_ := conclude " q-str "\n " + "**" "}\n (!right-either " p-str " " q-str "))"]}; + _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | _ => goal-stack } @@ -252,6 +271,7 @@ define set-goal := 'witnesses := [], 'parent := (), 'tactic := (cell []), + 'proof := (cell ""), 'children := (cell [])}|; _ := (set! root-goal goal-node); _ := (set! goal-stack [goal-node]); @@ -431,14 +451,14 @@ define tactic-dictionary := _ := (print "\nWe'll try to claim this goal:" goal ". Does it hold?: " cond1 ". Is it in the assumptions?: " cond2) } check {(|| cond1 cond2) => - let {_ := (set! (goal-record 'tactic) ['claim []])} + let {_ := (set! (goal-record 'proof) ["(!claim " (val->string goal) ")"]); + _ := (set! (goal-record 'tactic) ['claim []])} rest | else => let {_ := (print "\nNO DICE...\n")} (error "Incorrect application of 'claim tactic--the top goal does not hold.")} | _ => goal-stack } }| - define (spaces n) := check {(n less? 1) => "" | else => (join " " (spaces (n minus 1)))} @@ -522,6 +542,23 @@ define (apply-tactic* tactic-name args) := +define (show-proof) := + letrec {join-proof-chunks := lambda (proof-chunks children-proofs res) + match proof-chunks { + [] => (flatten (join (rev res))) + | (list-of chunk more) => check {(&& (equal? chunk "**") (negate (null? children-proofs))) => + (join-proof-chunks more + (tail children-proofs) + (add (first children-proofs) res)) + | else => (join-proof-chunks more children-proofs (add chunk res))} + }; + compose-proof := lambda (goal-record) + check {(leaf? goal-record) => (flatten (join (ref (goal-record 'proof)))) + | else => let {children-proofs := (map compose-proof (ref (goal-record 'children))); + proof-chunks := (ref (goal-record 'proof))} + (join-proof-chunks proof-chunks children-proofs [])}} + (compose-proof (ref root-goal)) + } # close module Tactics declare A, B, C, D, E: Boolean From 646fe06fbd4f105466ed31fd4cbcb7a2223a7db3 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Fri, 18 Oct 2024 13:34:22 -0400 Subject: [PATCH 15/49] Proofs produced for all tactics currently --- abstract_syntax.sml | 5 ++ lib/basic/list.ath | 13 +++- lib/basic/tactics.ath | 141 ++++++++++++++++++++++++++---------------- lib/basic/util.ath | 4 ++ names.sml | 3 + topenv_part1.sml | 9 +++ 6 files changed, 122 insertions(+), 53 deletions(-) diff --git a/abstract_syntax.sml b/abstract_syntax.sml index 472652f..39ddb34 100755 --- a/abstract_syntax.sml +++ b/abstract_syntax.sml @@ -1004,8 +1004,13 @@ and unparseCheckClause({test=boolCond(phr),result,...}:check_clause) = lparen^(u | unparseCheckClause({test=elseCond,result,...}:check_clause) = lparen^(Names.else_name)^space^(unparseExp(result))^rparen and unparseCheckClauses(clauses) = Basic.printSExpListStr(clauses,unparseCheckClause) and unparseBinding({bpat,def,...}) = lparen^(printPat bpat)^space^(unparsePhrase def)^rparen +and unparseBindingInfix({bpat,def,...}) = (printPat bpat)^ " := " ^(unparsePhrase def) and unparseBindings(bindings) = Basic.printSExpListStr(bindings,unparseBinding) +and unparseBindingsInfix(bindings) = Basic.printListStr(bindings,unparseBindingInfix,"; ") and unparseDed(methodAppDed({method,args,pos})) = "(!"^(unparseExp method)^space^(Basic.printSExpListStr(args,unparsePhrase))^")" + | unparseDed(UMethAppDed({method, arg, pos})) = "(!"^(unparseExp method)^space^(Basic.printSExpListStr([arg],unparsePhrase))^")" + | unparseDed(BMethAppDed({method, arg1, arg2, pos})) = "(!"^(unparseExp method)^space^(Basic.printSExpListStr([arg1,arg2],unparsePhrase))^")" + | unparseDed(letDed({bindings,body,pos,...})) = "let {"^(unparseBindingsInfix bindings)^"}"^space^(unparseDed body) | unparseDed(_) = "(Don't know how to unparse this deduction yet.)" and unparsePhrase(exp(e)) = unparseExp(e) | unparsePhrase(ded(d)) = unparseDed(d) diff --git a/lib/basic/list.ath b/lib/basic/list.ath index 732ad5a..aff7201 100644 --- a/lib/basic/list.ath +++ b/lib/basic/list.ath @@ -1039,4 +1039,15 @@ define (list->counts L) := [] => M | (list-of x rest) => (loop rest (Map.add M [[x try {(1 plus (M x)) | 1}]])) }} - (loop L (Map.make [])) \ No newline at end of file + (loop L (Map.make [])) + + +define (white-space-character? c) := (member? (char-ord c) [9 10 11 12 13 32 133 160]) + +define (white-space? str) := (for-each str white-space-character?) + +define (trim str chars-to-be-trimmed) := + check {(null? str) => str + | (member? (first str) chars-to-be-trimmed) => (trim (tail str) chars-to-be-trimmed) + | (member? (last str) chars-to-be-trimmed) => (trim (all-but-last str) chars-to-be-trimmed) + | else => str} \ No newline at end of file diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index a7dcb68..acae2e2 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -22,7 +22,8 @@ define (flip pol) := define (silence-on) := (process-input-from-string "(set-flag silent-mode \"on\")") define (silence-off) := (process-input-from-string "(set-flag silent-mode \"off\")") -define (merror str) := let {_ := (print "\nMERRORRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRR" str "\n")} (error str) + +define marker := "**" define (sub-sentence-map p) := letrec {loop := lambda (p M pos) @@ -212,19 +213,19 @@ define (backward-tactic goal-stack tactic-name) := let {make-new-goal-record := lambda (conjunct) (make-child goal-record [['goal conjunct]]); new-goal-records := (make-subgoals goal-record conjuncts); new-stack := (join new-goal-records rest); - proof-chunks := check {(equal? (length new-goal-records) 2) => ["(!both " "**" " " "**" ")"] - | else => (join ["(!conj-intro "] (separate (map (lambda (_) "**") conjuncts) " ") [")"])}; + proof-chunks := check {(equal? (length new-goal-records) 2) => ["(!both " marker " " marker ")"] + | else => (join ["(!conj-intro "] (separate (map (lambda (_) marker) conjuncts) " ") [")"])}; _ := (set! (goal-record 'proof) proof-chunks)} new-stack | (if (some-sentence p) (some-sentence q)) => let {goal-record' := (make-child goal-record [['goal q] ['assumptions (add-all p (goal-record 'assumptions))]]); proof-chunks := [(join "assume " (val->string p) "\n ") - "**"]; + marker]; _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | (iff (some-sentence p) (some-sentence q)) => let {goal-record' := (make-child goal-record [['goal (and (if p q) (if q p))]]); - proof-chunks := ["let {biconditional := " "**" "}\n (!equiv (!left-and biconditional) (!right-and biconditional))"]; + proof-chunks := ["let {biconditional := " marker "}\n (!equiv (!left-and biconditional) (!right-and biconditional))"]; _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | (or (some-sentence p) (some-sentence q)) => @@ -234,11 +235,11 @@ define (backward-tactic goal-stack tactic-name) := proof-chunks := check {(tactic-name equals? 'back-lor) => ["(!two-cases \n assume " q-str "\n (!right-either " p-str " " q-str ")\n " "\n assume (~ " q-str ")\n let {_ := conclude " p-str "\n " - "**" "}\n (!left-either " p-str " " q-str "))"] + marker "}\n (!left-either " p-str " " q-str "))"] | else => ["(!two-cases \n assume " p-str "\n (!left-either " p-str " " q-str ")\n " "\n assume (~ " p-str ")\n let {_ := conclude " q-str "\n " - "**" "}\n (!right-either " p-str " " q-str "))"]}; + marker "}\n (!right-either " p-str " " q-str "))"]}; _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | _ => goal-stack @@ -283,7 +284,8 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise) # This will produce a dictionary of the form # |{ # 'tactic-info := [ args], -# 'subgoals := +# 'subgoals := , +# 'proof := # }| # # where is a meta-identifier representing a proper (fully specified) extraction @@ -291,21 +293,51 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise) let {aux-info := |{'premise := premise, 'goal-parent := parent, 'parent-position-in-premise := parent-position-in-premise}|} match parent { - ((and (some-list props)) where (member? goal props)) => |{'tactic-info := ['and-> aux-info], 'subgoals := [parent]}| - + ((and (some-list props)) where (member? goal props)) => |{'tactic-info := ['and-> aux-info], + 'subgoals := [parent], + 'proof := check {(equal? (length props) 2) => + check {(equal? goal (first props)) => ["let {_ := " marker "\n }\n (!left-and " (val->string parent) ")"] + | else => ["let {_ := " marker "\n }\n (!right-and " (val->string parent) ")"] + } + | else => ["let {_ := " marker "\n }\n (!conj-elim " (val->string goal) " " (val->string parent) ")"] + } + }| | ((or (some-list props)) where (member? goal props)) => |{'tactic-info := ['or-> aux-info], + 'proof := let {index := (cell 1); + goal-str := (val->string goal); + trivial-case := (join "assume h := " goal-str "\n (!claim h)"); + case-chunks := (flatten + (map lambda (disjunct) + check {(equal? disjunct goal) => ["\ncase-" (val->string (inc index)) " := " trivial-case ";\n"] + | else => ["\ncase-" (val->string (inc index)) " := " marker ";\n"]} + props)); + _ := (set! index 1)} + (join ["let {disjunction := " (val->string parent)] + case-chunks + ["}\n (!cases disjunction " + (separate (map lambda (_) + (join "case-" (val->string (inc index))) + props) + " ") + ")"]), 'subgoals := (add parent (map-select-2 lambda (disjunct) (if disjunct goal) props lambda (disjunct) - (unequal? disjunct goal)))}| + (unequal? disjunct goal)))}| - | (if antecedent (val-of goal)) => |{'tactic-info := ['if-> aux-info], 'subgoals := [parent antecedent]}| + | (if antecedent (val-of goal)) => |{'tactic-info := ['if-> aux-info], + 'proof := ["let {cond := " marker ";\n ant := " marker "\n }\n (!mp cond ant)"], + 'subgoals := [parent antecedent]}| - | (iff left (val-of goal)) => |{'tactic-info := ['iff-left-> aux-info], 'subgoals := [parent left]}| + | (iff left (val-of goal)) => |{'tactic-info := ['iff-left-> aux-info], + 'proof := ["let {bicond := " marker ";\n left := " marker "\n }\n (!mp (!left-iff bicond) left)"], + 'subgoals := [parent left]}| - | (iff (val-of goal) right) => |{'tactic-info := ['iff-right-> aux-info], 'subgoals := [parent right]}| + | (iff (val-of goal) right) => |{'tactic-info := ['iff-right-> aux-info], + 'proof := ["let {bicond := " marker ";\n right := " marker "\n }\n (!mp (!right-iff bicond) right)"], + 'subgoals := [parent right]}| } @@ -325,6 +357,7 @@ define extraction-tactic := let { D := (proper-extraction-tactic goal premise parent position); [tactic-info subgoals] := [(D 'tactic-info) (D 'subgoals)]; _ := (set! (goal-record 'tactic) tactic-info); + _ := (set! (goal-record 'proof) (D 'proof)); counter := (cell 1); new-goal-records' := (map lambda (subgoal) (make-child goal-record [['goal subgoal] ['path (extend-path goal-record (inc counter))]]) subgoals) @@ -340,8 +373,10 @@ define contradiction-tactic := match goal-stack { (list-of goal-record rest) => let {goal := (goal-record 'goal); + goal-complement := (complement goal); _ := (set! (goal-record 'tactic) ['contradiction []]); - new-goal-record := (make-child goal-record [['assumptions (add-all (complement goal) (goal-record 'assumptions))] ['goal false]])} + _ := (set! (goal-record 'proof) ["(!by-contradiction " (val->string goal) "\n assume " (val->string goal-complement) "\n " marker ")"]); + new-goal-record := (make-child goal-record [['assumptions (add-all goal-complement (goal-record 'assumptions))] ['goal false]])} (add new-goal-record rest) | _ => (error "Invalid tactic application - there are no open goals currently.") } @@ -358,46 +393,22 @@ define from-complements-tactic := match goal-stack { (list-of goal-record rest) => match [(goal-record 'goal) args] { - # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: - [_ [complement-1 complement-2]] => + [goal [complement-1 complement-2]] => check {(hold-in [complement-1 complement-2] goal-record) => let {_ := (mark `1); - _ := (set! (goal-record 'tactic) ['from-complements [complement-1 complement-2]])} + _ := (set! (goal-record 'tactic) ['from-complements [complement-1 complement-2]]); + _ := (set! (goal-record 'proof) ["(!from-complements " (val->string goal) " " (val->string complement-1) " " (val->string complement-2) ")"]) + } rest - | else => (merror "Incorrect application of 'from-complements, at least one of the given complements does not hold.")} + | else => (error "Incorrect application of 'from-complements, at least one of the given complements does not hold.")} | _ => (print "Invalid information given to the tactic from-complements: exactly two sentences are required, each a complement of the other.") } - | _ => (merror "Invalid tactic application - there are no open goals currently.") + | _ => (error "Invalid tactic application - there are no open goals currently.") } -define (assert-all props) := - let {c := (cell []); - _ := (print "\nAbout to assert-all these assumptions: " props); - #_ := (silence-on); - _ := (map-proc lambda (p) let {_ := check {(holds? p) => () | else => (set! c (add p (ref c)))}; - cmd := (join "(assert " (val->string p) ")"); - _ := (print "\nCMD to execute: " cmd "\n") - } - (process-input-from-string cmd) - props); - _ := (map-proc (lambda (p) check {(holds? p) => (print "\nYES," p "holds...") | else => (print "\nNO, " p " STILL DOES NOT HOLD...")}) props); - _ := (silence-off)} - (ref c) - -define (retract-all props) := - let {_ := (silence-on); - _ := (map-proc lambda (p) (process-input-from-string (join "(retract " (val->string p) ")")) - props)} - (silence-off) define (execute-thunk M assumptions) := - let {#assumptions-not-already-in-ab := (assert-all assumptions); - #_ := (print "\nAB NOW: " (ab)); - p := assume (and assumptions) (!M); - #_ := (print "\nTHUNK RESULT: " p); - #_ := (retract-all assumptions-not-already-in-ab) - _ := () - } + let {p := assume (and assumptions) (!M)} (consequent p) define infer-tactic := @@ -406,12 +417,14 @@ define infer-tactic := match goal-stack { (list-of goal-record rest) => match args { - [(some-method M)] => + [M] => let {_ := (print "\nINSIDE INFER-TACTIC..."); lemma := (execute-thunk M (goal-record 'assumptions)); _ := (print "\nGOT THIS LEMMA: " lemma); new-goal := (make-child goal-record [['assumptions (add-all lemma (goal-record 'assumptions))]]); - _ := (set! (goal-record 'tactic) ['infer args])} + _ := (set! (goal-record 'tactic) ['infer args]); + _ := (set! (goal-record 'proof) ["let {_ := " (unparse-body M) "}\n " marker]) + } (add new-goal rest) | _ => (print "Invalid argument given to the infer tactic: A nullary method is expected.") } @@ -546,7 +559,7 @@ define (show-proof) := letrec {join-proof-chunks := lambda (proof-chunks children-proofs res) match proof-chunks { [] => (flatten (join (rev res))) - | (list-of chunk more) => check {(&& (equal? chunk "**") (negate (null? children-proofs))) => + | (list-of chunk more) => check {(&& (equal? chunk marker) (negate (null? children-proofs))) => (join-proof-chunks more (tail children-proofs) (add (first children-proofs) res)) @@ -572,9 +585,16 @@ assert p1 := (A ==> B & C) assert p2 := (~ B) (set-goal (not A)) (apply-tactic 'contradiction []) -(apply-tactic 'infer [(method () (!mp p1 A))]) + +(apply-tactic 'infer [method () (!mp p1 A)]) + (apply-tactic 'from-complements [B p2]) +(!by-contradiction (not A) + let {_ := (!mp p1 A)} + (!from-complements false B (not B))) + + (set-goal (if (and A B) (and B A))) @@ -589,10 +609,27 @@ define p := (and (not A) (not not A) (iff (A & B) (B & A)) (not not A));; (apply-tactic 'back-and []) - define [p1 p2] := [(A ==> B & C) (A & E)] assert [p1 p2] (set-goal C) (apply-tactic 'extract [p1]) (apply-tactic 'extract [p1]) -(apply-tactic 'extract [p2]) \ No newline at end of file +(apply-tactic 'extract [p2]) + + + +let {_ := let {cond := (!claim (if A (and B C))); + ant := let {_ := (!claim (and A E))} + (!left-and (and A E))} + } + (!mp cond ant) + } + (!right-and (and B C)) + + + + let {_ := let {cond := (!claim (if A (and B C))); + ant := let {_ := (!claim (and A E))} + (!left-and (and A E))} + (!mp cond ant)} + (!right-and (and B C)) diff --git a/lib/basic/util.ath b/lib/basic/util.ath index 077536d..7368d1c 100644 --- a/lib/basic/util.ath +++ b/lib/basic/util.ath @@ -5156,3 +5156,7 @@ define lambda-promote := define hol-fun := lambda-promote +define (unparse-body method-thunk) := + let {str := (unparse method-thunk)} + check {(prefix? "Method:" str) => (trim (all-but-last (drop str 18)) " ") + | else => (trim (all-but-last (drop str 10)) " ")} \ No newline at end of file diff --git a/names.sml b/names.sml index e3d541a..38e1642 100755 --- a/names.sml +++ b/names.sml @@ -973,6 +973,9 @@ val makeServerFun_symbol = Symbol.symbol makeServerFun_name val evalFun_name = "evaluate" val evalFun_symbol = Symbol.symbol evalFun_name +val unparseFun_name = "unparse" +val unparseFun_symbol = Symbol.symbol unparseFun_name + val processInputFun_name = "process-input-from-string" val processInputFun_symbol = Symbol.symbol processInputFun_name diff --git a/topenv_part1.sml b/topenv_part1.sml index c9ba6f3..009ed48 100755 --- a/topenv_part1.sml +++ b/topenv_part1.sml @@ -707,6 +707,15 @@ fun mergeSortPrimBFun'(v1,v2,env,ab) = listVal(Basic.mergeSortBuiltIn(vals,compare)) end)) +fun unparseFun([closMethodVal(A.methodExp({params=[],body,pos,name}),env_ref)],env,ab) = + let val proof_str = A.unparseDed(body) + in + MLStringToAthString(proof_str) + end + | unparseFun([v],_,{pos_ar,file}) = primError(wrongArgKind(N.unparseFun_name,1,closMethodLCType,v)) + | unparseFun(vals,_,{pos_ar,file}) = evError(wrongArgNumber(N.unparseFun_name,length(vals),1),SOME(Array.sub(pos_ar,0))) + + fun rootPrimUFun(v,env,ab) = (case coerceValIntoTerm(v) of SOME(t) => (case isGeneralApp(t) of From fb78a0e92b37057683f7bb25d21184aebf9aa789 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Sat, 19 Oct 2024 20:55:13 -0400 Subject: [PATCH 16/49] Go-back tactic working --- ab.sig | 3 ++ ab.sml | 10 +++- definition_processor.sml | 9 ++-- lib/basic/tactics.ath | 99 ++++++++++++++++++++++++++++++++++++---- prop.sig | 1 + prop.sml | 3 ++ 6 files changed, 112 insertions(+), 13 deletions(-) diff --git a/ab.sig b/ab.sig index d6f8cf0..280b69d 100755 --- a/ab.sig +++ b/ab.sig @@ -17,6 +17,8 @@ sig val insert: Prop.prop * assum_base -> assum_base + val insertAlongWithConjuncts: Prop.prop * assum_base -> assum_base + val remove: assum_base * Prop.prop -> assum_base val augment: assum_base * Prop.prop list -> assum_base @@ -48,6 +50,7 @@ sig val getAssertions: assum_base -> Prop.prop list val addAssertion: Prop.prop * assum_base -> assum_base + val addAssertionAlongWithConjuncts: Prop.prop * assum_base -> assum_base val addAssertions: Prop.prop list * assum_base -> assum_base val isAssertion: Prop.prop * assum_base -> bool diff --git a/ab.sml b/ab.sml index c8b232c..c1931e5 100755 --- a/ab.sml +++ b/ab.sml @@ -138,7 +138,11 @@ fun addAssertion(p,abase({prop_table,tag,...}):assum_base) = fun addAssertions(props,beta:assum_base) = let fun loop([],res) = res | loop(a::more,res) = loop(more,addAssertion(a,res)) - in loop(props,beta) end + in + loop(props,beta) + end + +fun addAssertionAlongWithConjuncts(p,ab) = addAssertions(p::(Prop.getConjunctsOnly p),ab) fun isAssertion(p,abase({prop_table,...}):assum_base) = (case IntBinaryMap.find(prop_table,getPropCode(p)) of @@ -212,10 +216,12 @@ fun insertAux(P,ab as abase({prop_table,tag,...}): assum_base) = abase({prop_table=IntBinaryMap.insert(prop_table,code,P),tag=inc(next_ab_tag)}) end -fun insert(P,ab) = insertAux(P,ab) +fun insert(P,ab) = insertAux(P,ab) fun augment(ab,props) = List.foldl insert ab props +fun insertAlongWithConjuncts(P,ab) = augment(ab,P::(Prop.getConjunctsOnly P)) + fun getAll(ab as abase({prop_table,...}):assum_base) = IntBinaryMap.listItems(prop_table) fun occursFree(v,ab) = List.exists (fn (P) => Prop.occursFree(v,P)) (getAll ab) diff --git a/definition_processor.sml b/definition_processor.sml index 482d2bf..909c92c 100755 --- a/definition_processor.sml +++ b/definition_processor.sml @@ -79,9 +79,12 @@ val pprint = TopEnv.pprint val top_assum_base = ABase.top_assum_base fun addPropToGlobalAb(p,mod_path,string_opt) = - (top_assum_base := ABase.insert(p,!top_assum_base); + let + in + (top_assum_base := ABase.insertAlongWithConjuncts(p,!top_assum_base); P.addToModuleAb(mod_path,p,string_opt); - top_assum_base := ABase.addAssertion(p,!top_assum_base)) + top_assum_base := ABase.addAssertionAlongWithConjuncts(p,!top_assum_base)) + end fun addPropsToGlobalAb(props,mod_path,string_opt) = List.app (fn p => addPropToGlobalAb(p,mod_path,string_opt)) props val top_val_env = SV.top_val_env @@ -1281,7 +1284,7 @@ fun printVal(Semantics.propVal(p),(true,_)) = fun addProp(v as Semantics.propVal(p),env,eval_env,(is_ded,name_opt),mod_path,definition_sym_opt) = if is_ded then - (top_assum_base := ABase.augment(!top_assum_base,[p]); + (top_assum_base := ABase.insertAlongWithConjuncts(p,!top_assum_base); (case (name_opt,definition_sym_opt) of (SOME(name),_) => (Semantics.updateTopValEnv(env,name,v,true);Semantics.updateTopValEnv(eval_env,name,v,true);P.addToModuleAb(mod_path,p,SOME(S.name(name)))) | (_,SOME(name)) => (Semantics.updateTopValEnv(env,name,v,true);Semantics.updateTopValEnv(eval_env,name,v,true);P.addToModuleAb(mod_path,p,SOME(S.name(name)))) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index acae2e2..6769919 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -23,6 +23,8 @@ define (flip pol) := define (silence-on) := (process-input-from-string "(set-flag silent-mode \"on\")") define (silence-off) := (process-input-from-string "(set-flag silent-mode \"off\")") +define (merror str) := let {_ := (print str)} + (error str) define marker := "**" define (sub-sentence-map p) := @@ -118,10 +120,12 @@ define (polarities-and-positions p q) := | _ => [] } -define (find-positive-goal-parent goal premise) := -# Find a positive subsentence of the premise, call it p, that is a parent of the goal. Return a pair of p and the position of p in premise. -# If no such subsentences exists, return (). +define (find-positive-parent goal premise) := +# Find a positive subsentence of the premise, call it p, that is a parent of the given goal. +# Return a pair of p and the position of p in premise. +# If no such subsentence exists, return (). # If more than one such subsentence exists, return the first one (in a DFS ordering of all subsentences of the premise). + let {subsentence-map := (sub-sentence-map premise); parent? := lambda (parent child) (member? child (children parent)); @@ -139,7 +143,18 @@ define (find-positive-goal-parent goal premise) := lambda (ss) [ss (first (first (subsentence-map ss)))] lambda (ss-pair) ss-pair lambda () ()) - + + +define (positive-in-ab? p props) := + let {F := lambda () false; + S := lambda (_) true} + (find-element props + lambda (q) + let {M := (sub-sentence-map q)} + try {let {_ := (M p)} true | false } + S + F) + # A record (or frame) on the goal stack has the following form: # |{ # 'goal := , @@ -326,7 +341,6 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise) props lambda (disjunct) (unequal? disjunct goal)))}| - | (if antecedent (val-of goal)) => |{'tactic-info := ['if-> aux-info], 'proof := ["let {cond := " marker ";\n ant := " marker "\n }\n (!mp cond ant)"], 'subgoals := [parent antecedent]}| @@ -351,7 +365,7 @@ define extraction-tactic := # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: [goal [premise]] => check {(negate (|| (member? premise (goal-record 'assumptions)) (holds? premise))) => (error "Invalid application of the extraction tactic: the given premise does not hold:\n" premise) - | else => match (find-positive-goal-parent goal premise) { + | else => match (find-positive-parent goal premise) { () => (error "Invalid application of the extraction tactic: the given premise does not have any positive occurrences of a goal parent") | [(some-sentence parent) position] => let { D := (proper-extraction-tactic goal premise parent position); @@ -366,6 +380,35 @@ define extraction-tactic := }} } } + +define case-analysis-tactic := + lambda (goal-stack args) + # We must return a new goal stack. + let {_ := (print "\nInside the case-analysis tactic, here's args: " args "\nand here is the goal stack: " goal-stack)} + match goal-stack { + (list-of goal-record rest) => + match [(goal-record 'goal) args] { + # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: + [goal [(disjunction as (or (some-list _)))]] => + let {disjuncts := (get-disjuncts disjunction)} + check {(positive-in-ab? disjunction (join (ab) (goal-record 'assumptions))) => + let {subgoals := (add disjunction (map lambda (disjunct) (if disjunct goal) + disjuncts)); + _ := (set! (goal-record 'tactic) ['case-analysis [disjunction]]); + index := (cell 1); + _ := (set! (goal-record 'proof) (join ["let {disjunction := " marker "}\n " "(!cases disjunction\n "] + (map lambda (d) marker + disjuncts) + [")"])); + counter := (cell 1); + new-goal-records' := (map lambda (subgoal) + (make-child goal-record [['goal subgoal] ['path (extend-path goal-record (inc counter))]]) + subgoals)} + (join new-goal-records' rest) + | else => (error "Invalid application of the case-analysis tactic: the given disjunction is not positively embedded in the current a.b.") + } + } + } define contradiction-tactic := lambda (goal-stack _) @@ -384,6 +427,8 @@ define contradiction-tactic := define (holds-in p goal-record) := (|| (holds? p) (member? p (goal-record 'assumptions))) +define (fails-in p goal-record) := (negate (holds-in p goal-record)) + define (hold-in props goal-record) := (for-each props lambda (p) (holds-in p goal-record)) define from-complements-tactic := @@ -431,6 +476,33 @@ define infer-tactic := | _ => (error "Invalid tactic application - there are no open goals currently.") } +define (go-back-to goal-stack target-path) := + let {new-stack := (filter-out goal-stack + lambda (goal-record) + (prefix? target-path (goal-record 'path)))} + letrec {navigate-to := lambda (current-goal-record current-path) + match current-path { + [] => current-goal-record + | (list-of index more) => (navigate-to (nth index (current-goal-record 'children)) more) + }} + try {let {target-goal := (navigate-to (ref root-goal) target-path); + _ := (set! (target-goal 'children) []); + _ := (set! (target-goal 'tactic) []); + _ := (set! (target-goal 'proof) "")} + (add target-goal new-stack) + | (error "Invalid path")} + +define go-back-tactic := + lambda (goal-stack args) + # We must return a new goal stack. + match goal-stack { + (list-of goal-record rest) => + match args { + ([path] where (for-each path numeral?)) => (go-back-to goal-stack path) + | _ => (merror "Invalid tactic application - the 'go-back tactic expects an argument of the form []") + } + | _ => (merror "Invalid tactic application - there are no open goals currently.") + } define tactic-dictionary := |{ @@ -442,6 +514,7 @@ define tactic-dictionary := 'extract := extraction-tactic, 'infer := infer-tactic, 'contradiction := contradiction-tactic, + 'case-analysis := case-analysis-tactic, 'from-complements := from-complements-tactic, 'back := lambda (goal-stack _) match goal-stack { @@ -455,6 +528,7 @@ define tactic-dictionary := } | _ => goal-stack }, + 'go-back := go-back-tactic, 'claim := lambda (goal-stack _) match goal-stack { (list-of goal-record rest) => @@ -581,15 +655,24 @@ open Tactics EOF load "lib/basic/tactics" + +assert d := (A | B | C) +assert con := (and (if A D) (if B D) (if C D)) +(set-goal D) + +(apply-tactic 'case-analysis [d]) + assert p1 := (A ==> B & C) assert p2 := (~ B) (set-goal (not A)) (apply-tactic 'contradiction []) - (apply-tactic 'infer [method () (!mp p1 A)]) +(apply-tactic 'go-back [[]]) (apply-tactic 'from-complements [B p2]) + + (!by-contradiction (not A) let {_ := (!mp p1 A)} (!from-complements false B (not B))) @@ -600,7 +683,7 @@ assert p2 := (~ B) define p := (and (not A) (not not A) (iff (A & B) (B & A)) (not not A));; -(find-positive-goal-parent A p) +(find-positive-parent A p) (apply-tactic 'back []) diff --git a/prop.sig b/prop.sig index 0fe2023..378f477 100755 --- a/prop.sig +++ b/prop.sig @@ -152,6 +152,7 @@ sig val decomposeConjunctionsStrict: prop -> prop list val getConjuncts: prop -> prop list + val getConjunctsOnly: prop -> prop list val getConjunctsLst: prop list -> prop list val foldConditionals: prop list * prop -> prop diff --git a/prop.sml b/prop.sml index d2915ff..890bf00 100755 --- a/prop.sml +++ b/prop.sml @@ -187,6 +187,9 @@ fun decomposeConjunctionsStrict(conj({args,...})) = (Basic.flatten (map decompos fun getConjuncts(p as conj({args,...})) = (List.foldl op@ [] (map getConjuncts args)) | getConjuncts(p) = [p] +fun getConjunctsOnly(p as conj({args,...})) = (List.foldl op@ args (map getConjunctsOnly args)) + | getConjunctsOnly(p) = [] + fun getConjunctsLst(props) = let fun loop([],res) = res | loop(p::more,res) = loop(more,(getConjuncts p)@res) From 1f5917673d41b66d261fcca99b9f43e98a1b4787 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Sun, 20 Oct 2024 10:58:53 -0400 Subject: [PATCH 17/49] Adding polarities.ath --- lib/basic/polarities.ath | 236 +++++++++++++++++++++++++++++++++++++++ lib/basic/tactics.ath | 195 +++++--------------------------- 2 files changed, 261 insertions(+), 170 deletions(-) create mode 100644 lib/basic/polarities.ath diff --git a/lib/basic/polarities.ath b/lib/basic/polarities.ath new file mode 100644 index 0000000..f98d558 --- /dev/null +++ b/lib/basic/polarities.ath @@ -0,0 +1,236 @@ +module Polarities { + +define (flip pol) := + match pol { + 'p => 'n + | 'n => 'p + | 'pn => 'pn} + +(define (positive-pol? pol) + (equal? pol 'p)) + +(define (negative-pol? pol) + (equal? pol 'n)) + +(define (subprop p pos) + (match [p pos] + ([_ []] p) + ([((some-sent-con _) (some-list props)) (list-of i rest)] (subprop (ith props i) rest)) + ([((some-quant q) (some-var _) (some-prop q)) (list-of 2 rest)] (subprop q rest)))) + +(define (polarities p q) + (let ((prepend-and-process (lambda (i f) + (lambda (pos-pol-pair) + (match pos-pol-pair + ([pos pol] [(add i pos) (f pol)]))))) + (id (lambda (x) x)) + (make-pos-neg (lambda (_) 'pn))) + (match q + ((val-of p) [[[] 'p]]) + ((not q1) (map (prepend-and-process 1 flip) + (polarities p q1))) + ((if q1 q2) (join (map (prepend-and-process 1 flip) + (polarities p q1)) + (map (prepend-and-process 2 id) + (polarities p q2)))) + ((iff q1 q2) (join (map (prepend-and-process 1 make-pos-neg) + (polarities p q1)) + (map (prepend-and-process 2 make-pos-neg) + (polarities p q2)))) + (((some-prop-con _) (some-list props)) + (let ((i (cell 1))) + (flatten (map (lambda (q) + (map (prepend-and-process (inc i) id) + (polarities p q))) + props)))) + (((some-quant _) (some-var _) (some-prop body)) + (map (prepend-and-process 2 id) + (polarities p body))) + (_ [])))) + +define (extend-map M k v) := + let {res := try { (M k) | [] }} + (Map.add M [[k (add v res)]]) + +# (sub-sentence-map p) returns a dictionary that maps every subsentence q of p +# to a list of pairs of the form [position polarity], where position is a Dewey path +# indicating the position of q in p (viewing p as a tree) and polarity indicates the polarity of q in p. +# A list of such pairs is returned because a single subsentence may have multiple occurrences in p. + +define (sub-sentence-map p) := + letrec {loop := lambda (p pos pol M) + match p { + (~ q) => (loop q (join pos [1]) (flip pol) (extend-map M p [pos pol])) + | (and (some-list args)) => + (loop* args + pos + pol + (extend-map M p [pos pol]) + 1) + | (or (some-list args)) => + (loop* args + pos + pol + (extend-map M p [pos pol]) + 1) + | (if p1 p2) => (loop p2 + (join pos [2]) + pol + (loop p1 + (join pos [1]) + (flip pol) + (extend-map M p [pos pol]))) + | (iff p1 p2) => let {M1 := (loop p1 (join pos [1]) 'pn M); + M2 := (loop p2 (join pos [2]) 'pn M1)} + (extend-map M2 p [pos pol]) + | _ => (extend-map M p [pos pol]) + }; + loop* := lambda (props pos pol M i) + match props { + [] => M + | (list-of p more) => + (loop* more + pos + pol + (loop p (join pos [i]) pol M) + (plus i 1)) + }} + (loop p [] 'p |{}|) + +define (find-positive-parent goal premise) := +# Find a positive subsentence of the premise, call it p, that is a parent of the given goal. +# Return a pair of p and the position of p in premise. +# If no such subsentence exists, return (). +# If more than one such subsentence exists, return the first one (in a DFS ordering of all subsentences of the premise). + + let {subsentence-map := (sub-sentence-map premise); + parent? := lambda (parent child) + (member? child (children parent)); + complex-non-negation := lambda (p) + (|| (conjunction? p) (disjunction? p) (conditional? p) (biconditional? p)); + positive? := lambda (position-polarity-pair) + (member? (second position-polarity-pair) + ['p 'pn])} + (find-element' (Map.keys subsentence-map) + lambda (ss-pos-pair) + let {[ss pos] := ss-pos-pair} + (&& (parent? ss goal) + (complex-non-negation ss) + (for-some (subsentence-map ss) positive?)) + lambda (ss) [ss (first (first (subsentence-map ss)))] + lambda (ss-pair) ss-pair + lambda () ()) + + +define (positive-in-ab? p props) := + let {F := lambda () false; + S := lambda (_) true} + (find-element props + lambda (q) + let {M := (sub-sentence-map q)} + try {let {_ := (M p)} true | false } + S + F) + +define (polarities-and-positions p q) := + let {prepend-and-process := + lambda (i f) + lambda (pos-pol-pair) + match pos-pol-pair { + [pos pol] => [(add i pos) (f pol)] + }; + id := lambda (x) x; + make-pos-neg := lambda (_) 'pn} + match q { + (val-of p) => [[[] 'p]] + | (~ q1) => (map (prepend-and-process 1 flip) + (polarities-and-positions p q1)) + | (q1 ==> q2) => (join (map (prepend-and-process 1 flip) + (polarities-and-positions p q1)) + (map (prepend-and-process 2 id) + (polarities-and-positions p q2))) + | (q1 <==> q2) => (join (map (prepend-and-process 1 make-pos-neg) + (polarities-and-positions p q1)) + (map (prepend-and-process 2 make-pos-neg) + (polarities-and-positions p q2))) + | ((some-sent-con _) (some-list args)) => + let {i := (cell 1)} + (flatten (map lambda (q) + (map (prepend-and-process (inc i) id) + (polarities-and-positions p q)) + args)) + | _ => [] + } + +(define (fpm r q p q-parent q-parent-pos q-pos q-pol) + (match (match-props r q) + ((some-sub theta) (check ((negative-pol? q-pol) []) + (else [[q (rev q-pos) theta q-parent (rev q-parent-pos) p]]))) + (_ (match q + ((not q') (fpm r q' p q q-pos (add 1 q-pos) (flip q-pol))) + ((if q1 q2) (join (fpm r q1 p q q-pos (add 1 q-pos) (flip q-pol)) + (fpm r q2 p q q-pos (add 2 q-pos) q-pol))) + ((iff q1 q2) (join (fpm r q1 p q q-pos (add 1 q-pos) 'pn) + (fpm r q2 p q q-pos (add 2 q-pos) 'pn))) + (((some-sent-con pc) (some-list props)) + (let ((i (cell 1))) + (flatten (map (lambda (q_i) + (fpm r q_i p q q-pos (add (inc i) q-pos) q-pol)) + props)))) + ((forall (some-var _) (some-sentence body)) + (check ((negative-pol? q-pol) []) + (else (fpm r body p q q-pos (add 2 q-pos) q-pol)))) + ((exists (some-var _) (some-sentence body)) + (check ((positive-pol? q-pol) []) + (else (fpm r body p q q-pos (add 2 q-pos) q-pol)))) + (_ []))))) + +(define (show-result p r res) + (match res + ([q q-pos theta q-parent q-parent-pos _] + (seq (println "[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[") + (print "Given target: ") (writeln-val r) + (print "\nGiven base prop (p) to search: ") (writeln-val p) + (print "\nThe target matched the following subsentence of p, call it q: ") (writeln-val q) + (print "\nIn position: ") (writeln-val q-pos) + (print "\nThe matching sub: ") (writeln-val theta) + (print "\nThe parent of q: ") (writeln-val q-parent) + (print "\nAnd the parent's position: ") (writeln-val q-parent-pos) + (print "]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]"))))) + + +define (list->sub result) := + match result { + [q q-pos theta q-parent q-parent-pos _] => + |{'matching-subsentence := q, + 'matching-subsentence-position := q-pos, + 'theta := theta, + 'match-parent := q-parent, + 'match-parent-position := q-parent-pos + }| + } + +define (find-proper-matches r p) := (map list->sub (fpm r p p p [] [] 'p)) + +define (top-level-match? D) := ((D 'matching-subsentence-position) equals? []) + +define (find-proper-matches* r props) := + letrec {loop := lambda (props results) + match props { + [] => (rev results) + | (list-of p more) => + match (find-proper-matches r p) { + [] => (loop more results) + | (results' as (list-of D _)) => + check {(top-level-match? D) => [D] + | else => (loop more (join results' results))} + } + }} + (loop props []) + +define (ufv q p q-pos-in-p) := + let {p-fvars := (fv p); + q-fvars := (fv (subprop p q-pos-in-p))} + (list-diff q-fvars p-fvars) + +} \ No newline at end of file diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 6769919..e40161e 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -1,174 +1,29 @@ +# load "/mnt/c/papers/dpls/dbook/proofs/pol" + +load "polarities" + module Tactics { -define (flip pol) := - match pol { - 'p => 'n - | 'n => 'p - | 'pn => 'pn} - - define (polarities p q) := - match q { - (val-of p) => ['p] - | (~ q1) => (map flip (polarities p q1)) - | (q1 ==> q2) => (join (map flip (polarities p q1)) - (polarities p q2)) - | (q1 <==> q2) => (map lambda (_) 'pn - (join (polarities p q1) (polarities p q2))) - | ((some-sent-con _) (some-list args)) => - (flatten (map lambda (q) (polarities p q) - args)) - | _ => [] - } - -define (silence-on) := (process-input-from-string "(set-flag silent-mode \"on\")") -define (silence-off) := (process-input-from-string "(set-flag silent-mode \"off\")") + define (silence-on) := (process-input-from-string "(set-flag silent-mode \"on\")") + define (silence-off) := (process-input-from-string "(set-flag silent-mode \"off\")") -define (merror str) := let {_ := (print str)} + define (merror str) := let {_ := (print str)} (error str) -define marker := "**" - -define (sub-sentence-map p) := - letrec {loop := lambda (p M pos) - match p { - ((some-sent-con _) (some-list args)) => (loop* args (Map.add M [[pos p]]) pos 1) - | _ => (Map.add M [[pos p]]) - }; - loop* := lambda (props M pos i) - match props { - [] => M - | (list-of p more) => (loop* more (loop p M (join pos [i])) pos (plus i 1)) - }} - (loop p |{}| []) - - -define (extend-map M k v) := - let {res := try { (M k) | [] }} - (Map.add M [[k (add v res)]]) - -# (sub-sentence-map p) returns a dictionary that maps every subsentence q of p -# to a list of pairs of the form [position polarity], where position is a Dewey path -# indicating the position of q in p (viewing p as a tree) and polarity indicates the polarity of q in p. -# A list of such pairs is returned because a single subsentence may have multiple occurrences in p. - -define (sub-sentence-map p) := - letrec {loop := lambda (p pos pol M) - match p { - (~ q) => (loop q (join pos [1]) (flip pol) (extend-map M p [pos pol])) - | (and (some-list args)) => - (loop* args - pos - pol - (extend-map M p [pos pol]) - 1) - | (or (some-list args)) => - (loop* args - pos - pol - (extend-map M p [pos pol]) - 1) - | (if p1 p2) => (loop p2 - (join pos [2]) - pol - (loop p1 - (join pos [1]) - (flip pol) - (extend-map M p [pos pol]))) - | (iff p1 p2) => let {M1 := (loop p1 (join pos [1]) 'pn M); - M2 := (loop p2 (join pos [2]) 'pn M1)} - (extend-map M2 p [pos pol]) - | _ => (extend-map M p [pos pol]) - }; - loop* := lambda (props pos pol M i) - match props { - [] => M - | (list-of p more) => - (loop* more - pos - pol - (loop p (join pos [i]) pol M) - (plus i 1)) - }} - (loop p [] 'p |{}|) - -define (polarities-and-positions p q) := - let {prepend-and-process := - lambda (i f) - lambda (pos-pol-pair) - match pos-pol-pair { - [pos pol] => [(add i pos) (f pol)] - }; - id := lambda (x) x; - make-pos-neg := lambda (_) 'pn} - match q { - (val-of p) => [[[] 'p]] - | (~ q1) => (map (prepend-and-process 1 flip) - (polarities-and-positions p q1)) - | (q1 ==> q2) => (join (map (prepend-and-process 1 flip) - (polarities-and-positions p q1)) - (map (prepend-and-process 2 id) - (polarities-and-positions p q2))) - | (q1 <==> q2) => (join (map (prepend-and-process 1 make-pos-neg) - (polarities-and-positions p q1)) - (map (prepend-and-process 2 make-pos-neg) - (polarities-and-positions p q2))) - | ((some-sent-con _) (some-list args)) => - let {i := (cell 1)} - (flatten (map lambda (q) - (map (prepend-and-process (inc i) id) - (polarities-and-positions p q)) - args)) - | _ => [] - } - -define (find-positive-parent goal premise) := -# Find a positive subsentence of the premise, call it p, that is a parent of the given goal. -# Return a pair of p and the position of p in premise. -# If no such subsentence exists, return (). -# If more than one such subsentence exists, return the first one (in a DFS ordering of all subsentences of the premise). - - let {subsentence-map := (sub-sentence-map premise); - parent? := lambda (parent child) - (member? child (children parent)); - complex-non-negation := lambda (p) - (|| (conjunction? p) (disjunction? p) (conditional? p) (biconditional? p)); - positive? := lambda (position-polarity-pair) - (member? (second position-polarity-pair) - ['p 'pn])} - (find-element' (Map.keys subsentence-map) - lambda (ss-pos-pair) - let {[ss pos] := ss-pos-pair} - (&& (parent? ss goal) - (complex-non-negation ss) - (for-some (subsentence-map ss) positive?)) - lambda (ss) [ss (first (first (subsentence-map ss)))] - lambda (ss-pair) ss-pair - lambda () ()) - - -define (positive-in-ab? p props) := - let {F := lambda () false; - S := lambda (_) true} - (find-element props - lambda (q) - let {M := (sub-sentence-map q)} - try {let {_ := (M p)} true | false } - S - F) - -# A record (or frame) on the goal stack has the following form: -# |{ -# 'goal := , -# 'id := , -# 'path := , -# 'assumptions := , -# 'eigenvariables := , -# 'witnesses := , -# 'parent := , -# 'children := , -# 'tactic := ] used to obtain the children goals> -# 'proof := h -# }| - + define marker := "**" + + # A record (or frame) on the goal stack has the following form: + # |{ + # 'goal := , + # 'id := , + # 'path := , + # 'assumptions := , + # 'eigenvariables := , + # 'witnesses := , + # 'parent := , + # 'children := , + # 'tactic := ] used to obtain the children goals> + # 'proof := h + # }| define goal-stack := (cell []) @@ -186,7 +41,7 @@ define (positive-in-ab? p props) := (seq (set! root-goal (cell ())) (set! goal-id-counter 0)) -# Apply a given tactic to the top goal: + # Apply a given tactic to the top goal: define (add-child goal-record child) := let {goal-children-cell := (goal-record 'children); @@ -365,7 +220,7 @@ define extraction-tactic := # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: [goal [premise]] => check {(negate (|| (member? premise (goal-record 'assumptions)) (holds? premise))) => (error "Invalid application of the extraction tactic: the given premise does not hold:\n" premise) - | else => match (find-positive-parent goal premise) { + | else => match (Polarities.find-positive-parent goal premise) { () => (error "Invalid application of the extraction tactic: the given premise does not have any positive occurrences of a goal parent") | [(some-sentence parent) position] => let { D := (proper-extraction-tactic goal premise parent position); @@ -391,7 +246,7 @@ define case-analysis-tactic := # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: [goal [(disjunction as (or (some-list _)))]] => let {disjuncts := (get-disjuncts disjunction)} - check {(positive-in-ab? disjunction (join (ab) (goal-record 'assumptions))) => + check {(Polarities.positive-in-ab? disjunction (join (ab) (goal-record 'assumptions))) => let {subgoals := (add disjunction (map lambda (disjunct) (if disjunct goal) disjuncts)); _ := (set! (goal-record 'tactic) ['case-analysis [disjunction]]); From 7eb12da726c4f23f87e784859f9568460c3e33c8 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 21 Oct 2024 10:10:26 -0400 Subject: [PATCH 18/49] WIP --- lib/basic/polarities.ath | 116 +++++++++++++++++++++++++++++---------- lib/basic/tactics.ath | 39 +++++++------ 2 files changed, 109 insertions(+), 46 deletions(-) diff --git a/lib/basic/polarities.ath b/lib/basic/polarities.ath index f98d558..a270cf1 100644 --- a/lib/basic/polarities.ath +++ b/lib/basic/polarities.ath @@ -16,7 +16,7 @@ define (flip pol) := (match [p pos] ([_ []] p) ([((some-sent-con _) (some-list props)) (list-of i rest)] (subprop (ith props i) rest)) - ([((some-quant q) (some-var _) (some-prop q)) (list-of 2 rest)] (subprop q rest)))) + ([((some-quant q) (some-var _) (some-sentence q)) (list-of 2 rest)] (subprop q rest)))) (define (polarities p q) (let ((prepend-and-process (lambda (i f) @@ -37,13 +37,13 @@ define (flip pol) := (polarities p q1)) (map (prepend-and-process 2 make-pos-neg) (polarities p q2)))) - (((some-prop-con _) (some-list props)) + (((some-sent-con _) (some-list props)) (let ((i (cell 1))) (flatten (map (lambda (q) (map (prepend-and-process (inc i) id) (polarities p q))) props)))) - (((some-quant _) (some-var _) (some-prop body)) + (((some-quant _) (some-var _) (some-sentence body)) (map (prepend-and-process 2 id) (polarities p body))) (_ [])))) @@ -97,30 +97,6 @@ define (sub-sentence-map p) := }} (loop p [] 'p |{}|) -define (find-positive-parent goal premise) := -# Find a positive subsentence of the premise, call it p, that is a parent of the given goal. -# Return a pair of p and the position of p in premise. -# If no such subsentence exists, return (). -# If more than one such subsentence exists, return the first one (in a DFS ordering of all subsentences of the premise). - - let {subsentence-map := (sub-sentence-map premise); - parent? := lambda (parent child) - (member? child (children parent)); - complex-non-negation := lambda (p) - (|| (conjunction? p) (disjunction? p) (conditional? p) (biconditional? p)); - positive? := lambda (position-polarity-pair) - (member? (second position-polarity-pair) - ['p 'pn])} - (find-element' (Map.keys subsentence-map) - lambda (ss-pos-pair) - let {[ss pos] := ss-pos-pair} - (&& (parent? ss goal) - (complex-non-negation ss) - (for-some (subsentence-map ss) positive?)) - lambda (ss) [ss (first (first (subsentence-map ss)))] - lambda (ss-pair) ss-pair - lambda () ()) - define (positive-in-ab? p props) := let {F := lambda () false; @@ -228,9 +204,89 @@ define (find-proper-matches* r props) := }} (loop props []) -define (ufv q p q-pos-in-p) := +define (ufv p subsentence-position) := +# This computes UFV(q,p) where q is the unique subsentence of p at subsentence-position: let {p-fvars := (fv p); - q-fvars := (fv (subprop p q-pos-in-p))} + q-fvars := (fv (subprop p subsentence-position))} (list-diff q-fvars p-fvars) + +define (find-universally-positive-parent goal premise) := + let {compromise-result := (cell ()); + update-theta := lambda (D) + let {parent-ufvs := (ufv premise (D 'match-parent-position)); + theta := (D 'theta); + extra-fvs := (list-diff parent-ufvs (supp theta))} + (extend-sub theta (map lambda (extra-fv) [extra-fv (fresh-var (sort-of extra-fv))] + extra-fvs)); + update-compromise := lambda (D) + check {(equal? (ref compromise-result) ()) => + (set! compromise-result [(D 'match-parent) (D 'match-parent-position) (update-theta D)]) + | else => ()}} + (find-element + (find-proper-matches goal premise) + lambda (D) + let {theta := (D 'theta); + match-pos := (D 'matching-subsentence-position); + ufv-vars := (ufv premise match-pos); + match-parent := (D 'match-parent); + match-parent-position := (D 'match-parent-position); + support := (supp theta)} + check {(subset? support ufv-vars) => + let {_ := (update-compromise D); + parent-ufvs := (ufv premise match-parent-position)} + (subset? parent-ufvs support) + | else => false} + lambda (D) [(D 'match-parent) (D 'match-parent-position) (D 'theta)] + lambda () (ref compromise-result)) + + +# Find a universally positive subsentence of the premise, call it q, that is a parent of the given goal. +# Return a pair of q and the position of q in the given premise. +# If no such subsentence exists, return (). +# If more than one such subsentence exists, return the first one (in a DFS ordering of all subsentences of the premise). + + # let {subsentence-map := (sub-sentence-map premise); + # parent? := lambda (parent child) + # (member? child (children parent)); + # complex-non-negation := lambda (p) + # (|| (conjunction? p) (disjunction? p) (conditional? p) (biconditional? p)); + # positive? := lambda (position-polarity-pair) + # (member? (second position-polarity-pair) + # ['p 'pn])} + # (find-element' (Map.keys subsentence-map) + # lambda (ss-pos-pair) + # let {[ss pos] := ss-pos-pair} + # (&& (parent? ss goal) + # (complex-non-negation ss) + # (for-some (subsentence-map ss) positive?)) + # lambda (ss) [ss (first (first (subsentence-map ss)))] + # lambda (ss-pair) ss-pair + # lambda () ()) + -} \ No newline at end of file +} + + +EOF + +declare zero:Int +declare succ: [Int] -> Int +declare pos: [Int] -> Boolean +declare a, b, c: Int + +define goal := (zero < succ a) + +define p1 := (forall x y . x < y ==> pos y) +define p2 := (forall x . zero < succ x) + + +(Polarities.find-universally-positive-parent (zero < succ a) p2) + +(Polarities.find-universally-positive-parent (pos succ a) p1) + +Need to prove: (?vf < succ a) +{?vf:Int --> zero +?x:Int --> a} + + +(Polarities.find-universally-positive-parent (?vf < succ a) p2) \ No newline at end of file diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index e40161e..0f21df6 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -150,7 +150,7 @@ define set-goal := (show-stack) } -define (proper-extraction-tactic goal premise parent parent-position-in-premise) := +define (proper-extraction-tactic goal premise parent parent-position-in-premise theta) := # This will produce a dictionary of the form # |{ # 'tactic-info := [ args], @@ -160,18 +160,25 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise) # # where is a meta-identifier representing a proper (fully specified) extraction # tactic name, and args is the list of all those values that are necessary for the tactic to work. - let {aux-info := |{'premise := premise, 'goal-parent := parent, 'parent-position-in-premise := parent-position-in-premise}|} - match parent { + let {aux-info := |{'premise := premise, 'goal-parent := parent, 'parent-position-in-premise := parent-position-in-premise, 'theta := theta}|; + instantiated-parent := (theta parent)} + + match instantiated-parent { - ((and (some-list props)) where (member? goal props)) => |{'tactic-info := ['and-> aux-info], - 'subgoals := [parent], - 'proof := check {(equal? (length props) 2) => - check {(equal? goal (first props)) => ["let {_ := " marker "\n }\n (!left-and " (val->string parent) ")"] - | else => ["let {_ := " marker "\n }\n (!right-and " (val->string parent) ")"] - } - | else => ["let {_ := " marker "\n }\n (!conj-elim " (val->string goal) " " (val->string parent) ")"] - } - }| + (and (some-list props)) => + let {conjuncts := (get-conjuncts instantiated-parent)} + check {(member? goal conjuncts) => + |{'tactic-info := ['and-> aux-info], + 'subgoals := [instantiated-parent], + 'proof := check {(equal? (length conjuncts) 2) => + check {(equal? goal (first conjuncts)) => + ["let {_ := " marker "\n }\n (!left-and " (val->string instantiated-parent) ")"] + | else => ["let {_ := " marker "\n }\n (!right-and " (val->string instantiated-parent) ")"] + } + | else => ["let {_ := " marker "\n }\n (!conj-elim " (val->string goal) " " instantiated-parent ")"]} + }| + | else => (error "Invalid application of conjunctive extraction tactic.")} + | ((or (some-list props)) where (member? goal props)) => |{'tactic-info := ['or-> aux-info], 'proof := let {index := (cell 1); goal-str := (val->string goal); @@ -220,10 +227,10 @@ define extraction-tactic := # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: [goal [premise]] => check {(negate (|| (member? premise (goal-record 'assumptions)) (holds? premise))) => (error "Invalid application of the extraction tactic: the given premise does not hold:\n" premise) - | else => match (Polarities.find-positive-parent goal premise) { - () => (error "Invalid application of the extraction tactic: the given premise does not have any positive occurrences of a goal parent") - | [(some-sentence parent) position] => - let { D := (proper-extraction-tactic goal premise parent position); + | else => match (Polarities.find-universally-positive-parent goal premise) { + () => (error "Invalid application of the extraction tactic: the given premise does not have any universally positive occurrences of a goal parent") + | [(some-sentence parent) parent-position-in-premise theta] => + let { D := (proper-extraction-tactic goal premise parent parent-position-in-premise theta); [tactic-info subgoals] := [(D 'tactic-info) (D 'subgoals)]; _ := (set! (goal-record 'tactic) tactic-info); _ := (set! (goal-record 'proof) (D 'proof)); From 73e0b04699f087dfe4f24a707528d76dae836b73 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 21 Oct 2024 12:01:15 -0400 Subject: [PATCH 19/49] Extraction tactics working for quantified logic, also added ugen3 --- lib/basic/tactics.ath | 109 +++++++++++++++++++++++------------------- 1 file changed, 61 insertions(+), 48 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 0f21df6..35d01e9 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -160,7 +160,8 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise # # where is a meta-identifier representing a proper (fully specified) extraction # tactic name, and args is the list of all those values that are necessary for the tactic to work. - let {aux-info := |{'premise := premise, 'goal-parent := parent, 'parent-position-in-premise := parent-position-in-premise, 'theta := theta}|; + let {aux-info := |{'premise := premise, 'goal-parent := parent, 'parent-position-in-premise := parent-position-in-premise, 'theta := theta}|; + _ := (print "\nHERE'S THETA: " theta); instantiated-parent := (theta parent)} match instantiated-parent { @@ -179,41 +180,57 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise }| | else => (error "Invalid application of conjunctive extraction tactic.")} - | ((or (some-list props)) where (member? goal props)) => |{'tactic-info := ['or-> aux-info], - 'proof := let {index := (cell 1); - goal-str := (val->string goal); - trivial-case := (join "assume h := " goal-str "\n (!claim h)"); - case-chunks := (flatten - (map lambda (disjunct) - check {(equal? disjunct goal) => ["\ncase-" (val->string (inc index)) " := " trivial-case ";\n"] - | else => ["\ncase-" (val->string (inc index)) " := " marker ";\n"]} - props)); - _ := (set! index 1)} - (join ["let {disjunction := " (val->string parent)] - case-chunks - ["}\n (!cases disjunction " - (separate (map lambda (_) - (join "case-" (val->string (inc index))) - props) - " ") - ")"]), - 'subgoals := (add parent - (map-select-2 lambda (disjunct) - (if disjunct goal) - props - lambda (disjunct) - (unequal? disjunct goal)))}| - | (if antecedent (val-of goal)) => |{'tactic-info := ['if-> aux-info], - 'proof := ["let {cond := " marker ";\n ant := " marker "\n }\n (!mp cond ant)"], - 'subgoals := [parent antecedent]}| + | (or (some-list _)) => + let {disjuncts := (get-disjuncts instantiated-parent)} + check {(member? goal disjuncts) => + |{'tactic-info := ['or-> aux-info], + 'subgoals := (add instantiated-parent + (map-select-2 lambda (disjunct) + (if disjunct goal) + disjuncts + lambda (disjunct) + (unequal? disjunct goal))), + 'proof := let {index := (cell 1); + goal-str := (val->string goal); + trivial-case := (join "assume h := " goal-str "\n (!claim h)"); + case-chunks := (flatten + (map lambda (disjunct) + check {(equal? disjunct goal) => ["\ncase-" (val->string (inc index)) " := " trivial-case ";\n"] + | else => ["\ncase-" (val->string (inc index)) " := " marker ";\n"]} + disjuncts)); + _ := (set! index 1)} + (join ["let {disjunction := " (val->string parent)] + case-chunks + ["}\n (!cases disjunction " + (separate (map lambda (_) + (join "case-" (val->string (inc index))) + disjuncts) + " ") + ")"])}| + | else => (error "Invalid application of disjunctive extraction tactic.")} + + | (if antecedent (val-of goal)) => + |{'tactic-info := ['if-> aux-info], + 'proof := ["let {cond := " marker ";\n ant := " marker "\n }\n (!mp cond ant)"], + 'subgoals := [instantiated-parent antecedent]}| - | (iff left (val-of goal)) => |{'tactic-info := ['iff-left-> aux-info], - 'proof := ["let {bicond := " marker ";\n left := " marker "\n }\n (!mp (!left-iff bicond) left)"], - 'subgoals := [parent left]}| + | (iff left (val-of goal)) => + |{'tactic-info := ['iff-left-> aux-info], + 'proof := ["let {bicond := " marker ";\n left := " marker "\n }\n (!mp (!left-iff bicond) left)"], + 'subgoals := [instantiated-parent left]}| - | (iff (val-of goal) right) => |{'tactic-info := ['iff-right-> aux-info], - 'proof := ["let {bicond := " marker ";\n right := " marker "\n }\n (!mp (!right-iff bicond) right)"], - 'subgoals := [parent right]}| + | (iff (val-of goal) right) => + |{'tactic-info := ['iff-right-> aux-info], + 'proof := ["let {bicond := " marker ";\n right := " marker "\n }\n (!mp (!right-iff bicond) right)"], + 'subgoals := [instantiated-parent right]}| + + | (forall (some-var v) (some-sentence _)) => + |{'tactic-info := ['forall3-> aux-info], + 'subgoals := let {_ := (print "\nINSTANTIATED PARENT: " instantiated-parent "\nAND PARENT: " parent)} + [instantiated-parent], + 'proof := let {theta' := (make-sub [[v (first (quant-vars parent))]])} + ["let {ugen := " marker "}\n (!uspec ugen " (val->string ((compose-subs theta theta') v)) ")"] + }| } @@ -512,6 +529,11 @@ define (show-proof) := declare A, B, C, D, E: Boolean +declare zero:Int +declare succ: [Int] -> Int +declare P, Q, pos: [Int] -> Boolean +declare a, b, c: Int + open Tactics EOF @@ -562,19 +584,10 @@ assert [p1 p2] (apply-tactic 'extract [p2]) +assert p1 := (forall x . P x ==> Q x) +assert p2 := (P a) -let {_ := let {cond := (!claim (if A (and B C))); - ant := let {_ := (!claim (and A E))} - (!left-and (and A E))} - } - (!mp cond ant) - } - (!right-and (and B C)) +(set-goal (Q a)) - - - let {_ := let {cond := (!claim (if A (and B C))); - ant := let {_ := (!claim (and A E))} - (!left-and (and A E))} - (!mp cond ant)} - (!right-and (and B C)) +(apply-tactic 'extract [p1]) +(apply-tactic 'extract [p1]) \ No newline at end of file From 253ab6037aef801cc2c2c3bd109684282f6da110 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 21 Oct 2024 12:37:34 -0400 Subject: [PATCH 20/49] WIP --- lib/basic/tactics.ath | 31 ++++++++++++++++++------------- lib/basic/util.ath | 11 ++++++----- 2 files changed, 24 insertions(+), 18 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 35d01e9..7240895 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -7,8 +7,9 @@ module Tactics { define (silence-on) := (process-input-from-string "(set-flag silent-mode \"on\")") define (silence-off) := (process-input-from-string "(set-flag silent-mode \"off\")") - define (merror str) := let {_ := (print str)} - (error str) + define error' := error + define (error str) := let {_ := (print str)} + (error' str) define marker := "**" # A record (or frame) on the goal stack has the following form: @@ -167,12 +168,13 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise match instantiated-parent { (and (some-list props)) => - let {conjuncts := (get-conjuncts instantiated-parent)} - check {(member? goal conjuncts) => + let {instantiated-conjuncts := (get-conjuncts instantiated-parent); + _ := (print "\nGoal: " goal "\nParent: " parent "\ninstantiated-parent: " instantiated-parent "\nconjuncts: " instantiated-conjuncts)} + check {(subset? (get-conjuncts goal) instantiated-conjuncts) => |{'tactic-info := ['and-> aux-info], 'subgoals := [instantiated-parent], - 'proof := check {(equal? (length conjuncts) 2) => - check {(equal? goal (first conjuncts)) => + 'proof := check {(equal? (length instantiated-conjuncts) 2) => + check {(equal? goal (first instantiated-conjuncts)) => ["let {_ := " marker "\n }\n (!left-and " (val->string instantiated-parent) ")"] | else => ["let {_ := " marker "\n }\n (!right-and " (val->string instantiated-parent) ")"] } @@ -378,9 +380,9 @@ define go-back-tactic := (list-of goal-record rest) => match args { ([path] where (for-each path numeral?)) => (go-back-to goal-stack path) - | _ => (merror "Invalid tactic application - the 'go-back tactic expects an argument of the form []") + | _ => (error "Invalid tactic application - the 'go-back tactic expects an argument of the form []") } - | _ => (merror "Invalid tactic application - there are no open goals currently.") + | _ => (error "Invalid tactic application - there are no open goals currently.") } define tactic-dictionary := @@ -531,7 +533,7 @@ declare A, B, C, D, E: Boolean declare zero:Int declare succ: [Int] -> Int -declare P, Q, pos: [Int] -> Boolean +declare P, Q, pos, T: [Int] -> Boolean declare a, b, c: Int open Tactics @@ -584,10 +586,13 @@ assert [p1 p2] (apply-tactic 'extract [p2]) -assert p1 := (forall x . P x ==> Q x) -assert p2 := (P a) +(clear-state) +assert p1 := (forall x . P x & Q x & T x) (set-goal (Q a)) - (apply-tactic 'extract [p1]) -(apply-tactic 'extract [p1]) \ No newline at end of file +(apply-tactic 'extract [p1]) + + + +(Polarities.find-universally-positive-parent (Q a) p1) \ No newline at end of file diff --git a/lib/basic/util.ath b/lib/basic/util.ath index 7368d1c..ec2e401 100644 --- a/lib/basic/util.ath +++ b/lib/basic/util.ath @@ -387,11 +387,6 @@ define (pairs->table L) := ((some-list args) (!map-method conj-intro args (method (_) (!and-intro args)))) ((some-sent p) (!claim p)))) -(define (conj-elim p C) - (dmatch C - ((and (some-list args)) (!decompose C (method (_) (!claim p)))) - (_ (!claim p)))) - (define (dhalt) (dlet ((_ (halt))) (!true-intro))) @@ -3742,6 +3737,12 @@ define raised-to := raise (define (simplify p q) (!decompose p (method (_) (!claim q)))) + +(define (conj-elim p C) + (dmatch C + ((and (some-list args)) (!decompose C (method (_) (!prove-components-of p)))) + (_ (!claim p)))) + (define (complement-conjunction C p) (!by-contradiction (complement C) (assume C From 9f17b895100e1120bced3eb7771636bd63e0fb8d Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 21 Oct 2024 12:45:17 -0400 Subject: [PATCH 21/49] Fix minor proof printing bug --- lib/basic/tactics.ath | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 7240895..664b1e7 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -178,7 +178,7 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise ["let {_ := " marker "\n }\n (!left-and " (val->string instantiated-parent) ")"] | else => ["let {_ := " marker "\n }\n (!right-and " (val->string instantiated-parent) ")"] } - | else => ["let {_ := " marker "\n }\n (!conj-elim " (val->string goal) " " instantiated-parent ")"]} + | else => ["let {_ := " marker "\n }\n (!conj-elim " (val->string goal) " " (val->string instantiated-parent) ")"]} }| | else => (error "Invalid application of conjunctive extraction tactic.")} @@ -590,7 +590,8 @@ assert [p1 p2] assert p1 := (forall x . P x & Q x & T x) (set-goal (Q a)) -(apply-tactic 'extract [p1]) +(apply-tactic* 'extract [p1]) + (apply-tactic 'extract [p1]) From 48395c646dbd9cb82d14f0b6bbe6cae4120883d0 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 21 Oct 2024 13:43:17 -0400 Subject: [PATCH 22/49] Forward and-> and or-> now working with arbitrarily complicated conjunctions and disjunctions --- lib/basic/polarities.ath | 56 +++++++++++++++++++++++++++++++++++++++- lib/basic/tactics.ath | 29 ++++++++++++++++----- 2 files changed, 78 insertions(+), 7 deletions(-) diff --git a/lib/basic/polarities.ath b/lib/basic/polarities.ath index a270cf1..9910fcd 100644 --- a/lib/basic/polarities.ath +++ b/lib/basic/polarities.ath @@ -137,8 +137,41 @@ define (polarities-and-positions p q) := args)) | _ => [] } - + + +define (get-disjuncts-and-their-positions p) := + letrec {loop := lambda (p path) + match p { + (or (some-list args)) => + let {index := (cell 1)} + (fold join + (map lambda (arg) + (loop arg (add (inc index) path)) + args) + []) + | _ => [[p path]] + }} + (loop p []) + +define (get-conjuncts-and-their-positions p) := + letrec {loop := lambda (p path) + match p { + (and (some-list args)) => + let {index := (cell 1)} + (fold join + (map lambda (arg) + (loop arg (add (inc index) path)) + args) + []) + | _ => [[p path]] + }} + (loop p []) + (define (fpm r q p q-parent q-parent-pos q-pos q-pol) +# Note: r and p (the target sentence and the sentence being searched) do not vary at all from call to call below - they're constant. +# Only q, and q-parent vary (along with their positions and polarities) from call to call. +# A more efficient/cleaner implementation would implement the recursive search via an internal procedure that did not take r and p as arguments. +# The final output is a list of search results, each of this form: [q q-pos theta q-parent q-parent-pos p] (match (match-props r q) ((some-sub theta) (check ((negative-pol? q-pol) []) (else [[q (rev q-pos) theta q-parent (rev q-parent-pos) p]]))) @@ -148,17 +181,38 @@ define (polarities-and-positions p q) := (fpm r q2 p q q-pos (add 2 q-pos) q-pol))) ((iff q1 q2) (join (fpm r q1 p q q-pos (add 1 q-pos) 'pn) (fpm r q2 p q q-pos (add 2 q-pos) 'pn))) + + ((or (some-list _)) + (let ((disjuncts-and-their-positions (get-disjuncts-and-their-positions q)) + (i (cell 1))) + (flatten (map (lambda (disjunct-and-its-position) + (let (([q_i q_i_pos] disjunct-and-its-position)) + (fpm r q_i p q q-pos (join q_i_pos q-pos) q-pol))) + disjuncts-and-their-positions)))) + + ((and (some-list _)) + (let ((conjuncts-and-their-positions (get-conjuncts-and-their-positions q)) + (i (cell 1))) + (flatten (map (lambda (conjunct-and-its-position) + (let (([q_i q_i_pos] conjunct-and-its-position)) + (fpm r q_i p q q-pos (join q_i_pos q-pos) q-pol))) + conjuncts-and-their-positions)))) + (((some-sent-con pc) (some-list props)) (let ((i (cell 1))) (flatten (map (lambda (q_i) (fpm r q_i p q q-pos (add (inc i) q-pos) q-pol)) props)))) + ((forall (some-var _) (some-sentence body)) (check ((negative-pol? q-pol) []) (else (fpm r body p q q-pos (add 2 q-pos) q-pol)))) ((exists (some-var _) (some-sentence body)) (check ((positive-pol? q-pol) []) (else (fpm r body p q q-pos (add 2 q-pos) q-pol)))) + ((exists-unique (some-var _) (some-sentence body)) + (check ((positive-pol? q-pol) []) + (else (fpm r body p q q-pos (add 2 q-pos) q-pol)))) (_ []))))) (define (show-result p r res) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 664b1e7..83a0f36 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -195,13 +195,15 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise 'proof := let {index := (cell 1); goal-str := (val->string goal); trivial-case := (join "assume h := " goal-str "\n (!claim h)"); + process-disjunct := lambda (disjunct tail-end) + check {(equal? disjunct goal) => ["\ncase-" (val->string (inc index)) " := " trivial-case tail-end] + | else => ["\ncase-" (val->string (inc index)) " := " marker tail-end]}; case-chunks := (flatten - (map lambda (disjunct) - check {(equal? disjunct goal) => ["\ncase-" (val->string (inc index)) " := " trivial-case ";\n"] - | else => ["\ncase-" (val->string (inc index)) " := " marker ";\n"]} - disjuncts)); + (join (map lambda (d) (process-disjunct d ";\n") + (all-but-last disjuncts)) + [(process-disjunct (last disjuncts) "\n")])); _ := (set! index 1)} - (join ["let {disjunction := " (val->string parent)] + (join ["let {disjunction := " marker ";\n"] case-chunks ["}\n (!cases disjunction " (separate (map lambda (_) @@ -587,10 +589,25 @@ assert [p1 p2] (clear-state) +(clear-assumption-base) + + assert p1 := (forall x . P x & Q x & T x) +(set-goal (Q a)) +(apply-tactic 'extract [p1]) + + +(clear-state) +(clear-assumption-base) + +assert p1 := (forall x . P x | Q x | T x) +assert p2 := (P a ==> Q a) +assert p3 := (T a ==> Q a) (set-goal (Q a)) -(apply-tactic* 'extract [p1]) + +(apply-tactic 'extract [p1]) + (apply-tactic 'extract [p1]) From dc38ea3d7327ad3121cb3518c76f0456fde71d37 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Tue, 22 Oct 2024 09:08:49 -0400 Subject: [PATCH 23/49] Tightened backward tactics --- lib/basic/tactics.ath | 44 ++++++++++++++++++++++++++++--------------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 83a0f36..9030e79 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -8,7 +8,7 @@ module Tactics { define (silence-off) := (process-input-from-string "(set-flag silent-mode \"off\")") define error' := error - define (error str) := let {_ := (print str)} + define (error str) := let {_ := (print (join "\n" str "\n"))} (error' str) define marker := "**" @@ -75,7 +75,7 @@ define (make-subgoals goal subgoals) := subgoals) define (backward-tactic goal-stack tactic-name) := -# This essentially ignores tactic-name for all cases except disjunctions. What if a tactic like 'back-and is applied to a conditional? +# This essentially ignores tactic-name for all cases except disjunctions. What if a tactic like 'and<- is applied to a conditional? match goal-stack { (list-of goal-record rest) => let {_ := (set! (goal-record 'tactic) [tactic-name []])} @@ -100,10 +100,11 @@ define (backward-tactic goal-stack tactic-name) := _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | (or (some-sentence p) (some-sentence q)) => - let {[new-goal new-assumption] := check {(tactic-name equals? 'back-lor) => [p (not q)] | else => [q (not p)]}; + let {[new-goal new-assumption] := check {(tactic-name equals? 'lor<-) => [p (not q)] | else => [q (not p)]}; goal-record' := (make-child goal-record [['goal new-goal] ['assumptions (add-all new-assumption (goal-record 'assumptions))]]); + _ := (print "\nHERE WE ARE...New goal:\n" new-goal); [p-str q-str] := [(val->string p) (val->string q)]; - proof-chunks := check {(tactic-name equals? 'back-lor) => + proof-chunks := check {(tactic-name equals? 'lor<-) => ["(!two-cases \n assume " q-str "\n (!right-either " p-str " " q-str ")\n " "\n assume (~ " q-str ")\n let {_ := conclude " p-str "\n " marker "}\n (!left-either " p-str " " q-str "))"] @@ -389,11 +390,11 @@ define go-back-tactic := define tactic-dictionary := |{ - 'back-lor := lambda (goal-stack _) (backward-tactic goal-stack 'lor), - 'back-ror := lambda (goal-stack _) (backward-tactic goal-stack 'back-ror), - 'back-if := lambda (goal-stack _) (backward-tactic goal-stack 'back-if), - 'back-iff := lambda (goal-stack _) (backward-tactic goal-stack 'back-iff), - 'back-and := lambda (goal-stack _) (backward-tactic goal-stack 'back-and), + 'lor<- := lambda (goal-stack _) (backward-tactic goal-stack 'lor<-), + 'ror<- := lambda (goal-stack _) (backward-tactic goal-stack 'ror<-), + 'if<- := lambda (goal-stack _) (backward-tactic goal-stack 'if<-), + 'iff<- := lambda (goal-stack _) (backward-tactic goal-stack 'iff<-), + 'and<- := lambda (goal-stack _) (backward-tactic goal-stack 'and<-), 'extract := extraction-tactic, 'infer := infer-tactic, 'contradiction := contradiction-tactic, @@ -403,11 +404,11 @@ define tactic-dictionary := match goal-stack { (list-of goal-record _) => match (goal-record 'goal) { - (and (some-list _)) => (backward-tactic goal-stack 'back-and) - | (or (some-list _)) => (backward-tactic goal-stack 'lor) - | (if _ _) => (backward-tactic goal-stack 'back-if) - | (iff _ _) => (backward-tactic goal-stack 'back-iff) - | _ => goal-stack + (and (some-list _)) => (backward-tactic goal-stack 'and<-) + | (or (some-list _)) => (backward-tactic goal-stack 'lor<-) + | (if _ _) => (backward-tactic goal-stack 'if<-) + | (iff _ _) => (backward-tactic goal-stack 'iff<-) + | _ => (error "Invalid application of 'back - no backward tactic is applicable to the this goal") } | _ => goal-stack }, @@ -577,7 +578,7 @@ define p := (and (not A) (not not A) (iff (A & B) (B & A)) (not not A));; (apply-tactic* 'back []) -(apply-tactic 'back-and []) +(apply-tactic 'and<- []) define [p1 p2] := [(A ==> B & C) (A & E)] @@ -597,6 +598,19 @@ assert p1 := (forall x . P x & Q x & T x) (apply-tactic 'extract [p1]) +(clear-state) +(clear-assumption-base) + +load "lib/basic/tactics" +assert p1 := (forall x . P x | T x ==> Q x) +assert p2 := (P a) +(set-goal (Q a)) +(apply-tactic 'extract [p1]) +(apply-tactic 'extract [p1]) +(show-tree) +(apply-tactic 'lor<- []) +---> THIS NOW GIVES INFINITE LOOP: (apply-tactic 'back []) + (clear-state) (clear-assumption-base) From 140b55d26868a923cc3d6784ad5526c94d006bc4 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Tue, 22 Oct 2024 10:09:43 -0400 Subject: [PATCH 24/49] Better formatting --- lib/basic/tactics.ath | 49 +++++++++++++++++++++++++++++++++---------- 1 file changed, 38 insertions(+), 11 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 9030e79..402ca07 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -78,15 +78,29 @@ define (backward-tactic goal-stack tactic-name) := # This essentially ignores tactic-name for all cases except disjunctions. What if a tactic like 'and<- is applied to a conditional? match goal-stack { (list-of goal-record rest) => - let {_ := (set! (goal-record 'tactic) [tactic-name []])} - match (goal-record 'goal) { - (and (some-list conjuncts)) => - let {make-new-goal-record := lambda (conjunct) (make-child goal-record [['goal conjunct]]); + let {_ := (set! (goal-record 'tactic) [tactic-name []]); + goal := (goal-record 'goal)} + match goal { + (and (some-list _)) => + let {conjuncts := (get-conjuncts goal); new-goal-records := (make-subgoals goal-record conjuncts); - new-stack := (join new-goal-records rest); - proof-chunks := check {(equal? (length new-goal-records) 2) => ["(!both " marker " " marker ")"] - | else => (join ["(!conj-intro "] (separate (map (lambda (_) marker) conjuncts) " ") [")"])}; - _ := (set! (goal-record 'proof) proof-chunks)} + new-stack := (join new-goal-records rest); + proof-chunks := check {(equal? (length conjuncts) 2) => ["(!both " marker " " marker ")"] + | else => let {counter := (cell 1); + _ := (mark `1); + components := (flatten (map lambda (_) [(join "conjunct-" (val->string (inc counter)) " := ") marker ";\n"] + (all-but-last conjuncts))); + _ := (mark `2); + last-component := [(join "conjunct-" (val->string (inc counter)) " := ") marker "\n"]; + _ := (mark `3)} + (add "let {" (join components + last-component + ["}\n (!conj-intro ["] + [let {index := (cell 1)} (trim (flatten (map lambda (_) (join "conjunct-" (val->string (inc index)) " ") + conjuncts)) " ")] + ["])"])) + }; + _ := (set! (goal-record 'proof) proof-chunks)} new-stack | (if (some-sentence p) (some-sentence q)) => let {goal-record' := (make-child goal-record [['goal q] ['assumptions (add-all p (goal-record 'assumptions))]]); @@ -485,7 +499,7 @@ define (apply-tactic tactic-name args) := let {# Retrieve the tactic by name: tactic := (tactic-dictionary tactic-name); _ := (print "\nGot the tactic, and here's the args: " args); - # Apply the tactic to the goal-stack: + # Apply the tactic to the goal-stack, to get either an error or a new goal stack: new-stack := (try (tactic (ref goal-stack) args) 'error)} match new-stack { 'error => 'error @@ -545,6 +559,11 @@ EOF load "lib/basic/tactics" +assert c := (A & B & C) +(set-goal (B & C & A)) +(apply-tactic 'and<- []) +(print (show-proof)) + assert d := (A | B | C) assert con := (and (if A D) (if B D) (if C D)) (set-goal D) @@ -605,11 +624,19 @@ load "lib/basic/tactics" assert p1 := (forall x . P x | T x ==> Q x) assert p2 := (P a) (set-goal (Q a)) +# This sequence fails to revert to state [1], even though it should: +(apply-tactic 'extract [p1]) +(apply-tactic 'back []) +(apply-tactic 'go-back [[1]]) + +# This now Works: (apply-tactic 'extract [p1]) (apply-tactic 'extract [p1]) -(show-tree) (apply-tactic 'lor<- []) ----> THIS NOW GIVES INFINITE LOOP: (apply-tactic 'back []) +or equivalently: +(apply-tactic* 'extract [p1]) +(apply-tactic 'back []) + (clear-state) (clear-assumption-base) From 27cba3819e0c7881d731175376ffbd30c06d712f Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Tue, 22 Oct 2024 11:24:54 -0400 Subject: [PATCH 25/49] More flexible backward tactics for disjunctions --- lib/basic/tactics.ath | 78 ++++++++++++++++++++++++++++++++++--------- 1 file changed, 62 insertions(+), 16 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 402ca07..a879262 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -74,11 +74,11 @@ define (make-subgoals goal subgoals) := (map lambda (p) (make-subgoal p (inc counter)) subgoals) -define (backward-tactic goal-stack tactic-name) := +define (backward-tactic goal-stack tactic-name args) := # This essentially ignores tactic-name for all cases except disjunctions. What if a tactic like 'and<- is applied to a conditional? match goal-stack { (list-of goal-record rest) => - let {_ := (set! (goal-record 'tactic) [tactic-name []]); + let {_ := (set! (goal-record 'tactic) [tactic-name args]); goal := (goal-record 'goal)} match goal { (and (some-list _)) => @@ -87,12 +87,9 @@ define (backward-tactic goal-stack tactic-name) := new-stack := (join new-goal-records rest); proof-chunks := check {(equal? (length conjuncts) 2) => ["(!both " marker " " marker ")"] | else => let {counter := (cell 1); - _ := (mark `1); components := (flatten (map lambda (_) [(join "conjunct-" (val->string (inc counter)) " := ") marker ";\n"] (all-but-last conjuncts))); - _ := (mark `2); - last-component := [(join "conjunct-" (val->string (inc counter)) " := ") marker "\n"]; - _ := (mark `3)} + last-component := [(join "conjunct-" (val->string (inc counter)) " := ") marker "\n"]} (add "let {" (join components last-component ["}\n (!conj-intro ["] @@ -113,6 +110,38 @@ define (backward-tactic goal-stack tactic-name) := proof-chunks := ["let {biconditional := " marker "}\n (!equiv (!left-and biconditional) (!right-and biconditional))"]; _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) + | (or (some-list _)) => + let {disjuncts := (get-disjuncts goal)} + check {(member? tactic-name ['lor<- 'ror<-]) => + # If we're specifically applying 'lor or 'ror, then the given disjunction should be binary and the new subgoal will become either the left or the right disjunct, respectively. + # In this case we're going to ignore the value of args. + match goal { + (or (some-sentence p) (some-sentence q)) => + let {[new-goal method-name] := check {(equal? tactic-name 'lor<-) => [p "left-either "] + | else => [q "right-either "]}; + new-goal-record := (make-child goal-record [['goal new-goal]]); + proof-chunks := ["let {_ := " marker "}\n " (join "(!" method-name (val->string p) " " (val->string q) ")")]; + _ := (set! (goal-record 'proof) proof-chunks)} + (add new-goal-record rest) + | _ => (error (join "Invalid application of " tactic-name))} + | (&& (member? tactic-name ['back 'or<-]) (null? args)) => + # If we're generically applying 'back without any additional info, then one of the disjuncts had better hold: + (find-element disjuncts + holds? + lambda (d) + let {new-goal-record := (make-child goal-record [['goal d]]); + proof-chunks := ["let {_ := " marker "}\n " (join "(!either " (val->string goal) ")")]; + _ := (set! (goal-record 'proof) proof-chunks)} + (add new-goal-record rest) + lambda () + (error "Invalid application of 'back to a disjunction.")) + | (&& (member? tactic-name ['back 'or<-]) (equal? (length args) 1) (sentence? (first args))) => + let {subgoal := (first args); + new-goal-record := (make-child goal-record [['goal subgoal]]); + proof-chunks := ["let {_ := " marker "}\n " (join "(!either " (val->string goal) ")")]; + _ := (set! (goal-record 'proof) proof-chunks)} + (add new-goal-record rest) + | else => (error "Invalid backward tactic application to a disjunction.")} | (or (some-sentence p) (some-sentence q)) => let {[new-goal new-assumption] := check {(tactic-name equals? 'lor<-) => [p (not q)] | else => [q (not p)]}; goal-record' := (make-child goal-record [['goal new-goal] ['assumptions (add-all new-assumption (goal-record 'assumptions))]]); @@ -404,24 +433,25 @@ define go-back-tactic := define tactic-dictionary := |{ - 'lor<- := lambda (goal-stack _) (backward-tactic goal-stack 'lor<-), - 'ror<- := lambda (goal-stack _) (backward-tactic goal-stack 'ror<-), - 'if<- := lambda (goal-stack _) (backward-tactic goal-stack 'if<-), - 'iff<- := lambda (goal-stack _) (backward-tactic goal-stack 'iff<-), - 'and<- := lambda (goal-stack _) (backward-tactic goal-stack 'and<-), + 'lor<- := lambda (goal-stack args) (backward-tactic goal-stack 'lor<- args), + 'ror<- := lambda (goal-stack args) (backward-tactic goal-stack 'ror<- args), + 'or<- := lambda (goal-stack args) (backward-tactic goal-stack 'or<- args), + 'if<- := lambda (goal-stack args) (backward-tactic goal-stack 'if<- args), + 'iff<- := lambda (goal-stack args) (backward-tactic goal-stack 'iff<- args), + 'and<- := lambda (goal-stack args) (backward-tactic goal-stack 'and<- args), 'extract := extraction-tactic, 'infer := infer-tactic, 'contradiction := contradiction-tactic, 'case-analysis := case-analysis-tactic, 'from-complements := from-complements-tactic, - 'back := lambda (goal-stack _) + 'back := lambda (goal-stack args) match goal-stack { (list-of goal-record _) => match (goal-record 'goal) { - (and (some-list _)) => (backward-tactic goal-stack 'and<-) - | (or (some-list _)) => (backward-tactic goal-stack 'lor<-) - | (if _ _) => (backward-tactic goal-stack 'if<-) - | (iff _ _) => (backward-tactic goal-stack 'iff<-) + (and (some-list _)) => (backward-tactic goal-stack 'and<- args) + | (or (some-list _)) => (backward-tactic goal-stack 'back args) + | (if _ _) => (backward-tactic goal-stack 'if<- args) + | (iff _ _) => (backward-tactic goal-stack 'iff<- args) | _ => (error "Invalid application of 'back - no backward tactic is applicable to the this goal") } | _ => goal-stack @@ -558,12 +588,28 @@ open Tactics EOF load "lib/basic/tactics" +assert [B C] +(set-goal (A | (B & C) | D)) +(apply-tactic 'or<- [(B & C)]) + +(print (show-proof)) + +assert c := (A & B) +(set-goal (B & A)) +(apply-tactic 'and<- []) +(print (show-proof)) assert c := (A & B & C) (set-goal (B & C & A)) (apply-tactic 'and<- []) (print (show-proof)) +assert c := B +(set-goal (A | B | C)) +(apply-tactic 'back []) +(print (show-proof)) + + assert d := (A | B | C) assert con := (and (if A D) (if B D) (if C D)) (set-goal D) From 01960ebb8a5915cbea0cef6250971e55a794c30b Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Tue, 22 Oct 2024 11:45:32 -0400 Subject: [PATCH 26/49] Fixed reverting bug --- lib/basic/tactics.ath | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index a879262..0997cbd 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -367,8 +367,7 @@ define from-complements-tactic := match [(goal-record 'goal) args] { [goal [complement-1 complement-2]] => check {(hold-in [complement-1 complement-2] goal-record) => - let {_ := (mark `1); - _ := (set! (goal-record 'tactic) ['from-complements [complement-1 complement-2]]); + let {_ := (set! (goal-record 'tactic) ['from-complements [complement-1 complement-2]]); _ := (set! (goal-record 'proof) ["(!from-complements " (val->string goal) " " (val->string complement-1) " " (val->string complement-2) ")"]) } rest @@ -410,15 +409,17 @@ define (go-back-to goal-stack target-path) := letrec {navigate-to := lambda (current-goal-record current-path) match current-path { [] => current-goal-record - | (list-of index more) => (navigate-to (nth index (current-goal-record 'children)) more) + | (list-of index more) => (navigate-to (nth index (ref (current-goal-record 'children))) more) }} - try {let {target-goal := (navigate-to (ref root-goal) target-path); + try {let {_ := (mark `1); + target-goal := (navigate-to (ref root-goal) target-path); + _ := (mark `2); _ := (set! (target-goal 'children) []); _ := (set! (target-goal 'tactic) []); _ := (set! (target-goal 'proof) "")} (add target-goal new-stack) | (error "Invalid path")} - + define go-back-tactic := lambda (goal-stack args) # We must return a new goal stack. @@ -588,9 +589,8 @@ open Tactics EOF load "lib/basic/tactics" -assert [B C] -(set-goal (A | (B & C) | D)) -(apply-tactic 'or<- [(B & C)]) +(set-goal (A & B <==> B & A)) +(apply-tactic* 'back []) (print (show-proof)) From 18953a5e95af7d81d8b38894ff080f1a1edf5142 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Wed, 23 Oct 2024 09:42:54 -0400 Subject: [PATCH 27/49] Richer markers --- athena.mlb | 1 + lib/basic/tactics.ath | 78 +++++++++++++++++++++---------------------- 2 files changed, 40 insertions(+), 39 deletions(-) diff --git a/athena.mlb b/athena.mlb index 37d9b63..6970b8b 100755 --- a/athena.mlb +++ b/athena.mlb @@ -92,5 +92,6 @@ in repl.sml athena.sml sml_c_util.sml + mlton_main_old.sml mlton_main.sml end diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 0997cbd..f489990 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -10,7 +10,14 @@ module Tactics { define error' := error define (error str) := let {_ := (print (join "\n" str "\n"))} (error' str) - define marker := "**" + + define [marker current-marker-counter] := + let {marker-counter := (cell 1)} + [lambda () + (join "**" (val->string (inc marker-counter))) + lambda () (ref marker-counter)] + + define marker-transformations := (HashTable.table 100) # A record (or frame) on the goal stack has the following form: # |{ @@ -85,11 +92,11 @@ define (backward-tactic goal-stack tactic-name args) := let {conjuncts := (get-conjuncts goal); new-goal-records := (make-subgoals goal-record conjuncts); new-stack := (join new-goal-records rest); - proof-chunks := check {(equal? (length conjuncts) 2) => ["(!both " marker " " marker ")"] + proof-chunks := check {(equal? (length conjuncts) 2) => ["(!both " (marker) " " (marker) ")"] | else => let {counter := (cell 1); - components := (flatten (map lambda (_) [(join "conjunct-" (val->string (inc counter)) " := ") marker ";\n"] + components := (flatten (map lambda (_) [(join "conjunct-" (val->string (inc counter)) " := ") (marker) ";\n"] (all-but-last conjuncts))); - last-component := [(join "conjunct-" (val->string (inc counter)) " := ") marker "\n"]} + last-component := [(join "conjunct-" (val->string (inc counter)) " := ") (marker) "\n"]} (add "let {" (join components last-component ["}\n (!conj-intro ["] @@ -102,12 +109,12 @@ define (backward-tactic goal-stack tactic-name args) := | (if (some-sentence p) (some-sentence q)) => let {goal-record' := (make-child goal-record [['goal q] ['assumptions (add-all p (goal-record 'assumptions))]]); proof-chunks := [(join "assume " (val->string p) "\n ") - marker]; + (marker)]; _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | (iff (some-sentence p) (some-sentence q)) => let {goal-record' := (make-child goal-record [['goal (and (if p q) (if q p))]]); - proof-chunks := ["let {biconditional := " marker "}\n (!equiv (!left-and biconditional) (!right-and biconditional))"]; + proof-chunks := ["let {biconditional := " (marker) "}\n (!equiv (!left-and biconditional) (!right-and biconditional))"]; _ := (set! (goal-record 'proof) proof-chunks)} (add goal-record' rest) | (or (some-list _)) => @@ -120,7 +127,7 @@ define (backward-tactic goal-stack tactic-name args) := let {[new-goal method-name] := check {(equal? tactic-name 'lor<-) => [p "left-either "] | else => [q "right-either "]}; new-goal-record := (make-child goal-record [['goal new-goal]]); - proof-chunks := ["let {_ := " marker "}\n " (join "(!" method-name (val->string p) " " (val->string q) ")")]; + proof-chunks := ["let {_ := " (marker) "}\n " (join "(!" method-name (val->string p) " " (val->string q) ")")]; _ := (set! (goal-record 'proof) proof-chunks)} (add new-goal-record rest) | _ => (error (join "Invalid application of " tactic-name))} @@ -130,7 +137,7 @@ define (backward-tactic goal-stack tactic-name args) := holds? lambda (d) let {new-goal-record := (make-child goal-record [['goal d]]); - proof-chunks := ["let {_ := " marker "}\n " (join "(!either " (val->string goal) ")")]; + proof-chunks := ["let {_ := " (marker) "}\n " (join "(!either " (val->string goal) ")")]; _ := (set! (goal-record 'proof) proof-chunks)} (add new-goal-record rest) lambda () @@ -138,25 +145,16 @@ define (backward-tactic goal-stack tactic-name args) := | (&& (member? tactic-name ['back 'or<-]) (equal? (length args) 1) (sentence? (first args))) => let {subgoal := (first args); new-goal-record := (make-child goal-record [['goal subgoal]]); - proof-chunks := ["let {_ := " marker "}\n " (join "(!either " (val->string goal) ")")]; + proof-chunks := ["let {_ := " (marker) "}\n " (join "(!either " (val->string goal) ")")]; _ := (set! (goal-record 'proof) proof-chunks)} (add new-goal-record rest) | else => (error "Invalid backward tactic application to a disjunction.")} - | (or (some-sentence p) (some-sentence q)) => - let {[new-goal new-assumption] := check {(tactic-name equals? 'lor<-) => [p (not q)] | else => [q (not p)]}; - goal-record' := (make-child goal-record [['goal new-goal] ['assumptions (add-all new-assumption (goal-record 'assumptions))]]); - _ := (print "\nHERE WE ARE...New goal:\n" new-goal); - [p-str q-str] := [(val->string p) (val->string q)]; - proof-chunks := check {(tactic-name equals? 'lor<-) => - ["(!two-cases \n assume " q-str "\n (!right-either " p-str " " q-str ")\n " - "\n assume (~ " q-str ")\n let {_ := conclude " p-str "\n " - marker "}\n (!left-either " p-str " " q-str "))"] - | else => - ["(!two-cases \n assume " p-str "\n (!left-either " p-str " " q-str ")\n " - "\n assume (~ " p-str ")\n let {_ := conclude " q-str "\n " - marker "}\n (!right-either " p-str " " q-str "))"]}; - _ := (set! (goal-record 'proof) proof-chunks)} - (add goal-record' rest) + | (forall (some-list vars) (some-sentence body)) => + let {fresh-vars := (map lambda (v) (fresh-var (sort-of v) (var->string v)) vars); + subgoal := (replace-vars vars fresh-vars body); + new-goal-record := (make-child goal-record [['goal subgoal]]); + proof-chunks := (join ["pick-any "] (map var->string vars) ["\n " (marker)])} + (error "Not yet implemented") | _ => goal-stack } | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") @@ -219,10 +217,10 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise 'subgoals := [instantiated-parent], 'proof := check {(equal? (length instantiated-conjuncts) 2) => check {(equal? goal (first instantiated-conjuncts)) => - ["let {_ := " marker "\n }\n (!left-and " (val->string instantiated-parent) ")"] - | else => ["let {_ := " marker "\n }\n (!right-and " (val->string instantiated-parent) ")"] + ["let {_ := " (marker) "\n }\n (!left-and " (val->string instantiated-parent) ")"] + | else => ["let {_ := " (marker) "\n }\n (!right-and " (val->string instantiated-parent) ")"] } - | else => ["let {_ := " marker "\n }\n (!conj-elim " (val->string goal) " " (val->string instantiated-parent) ")"]} + | else => ["let {_ := " (marker) "\n }\n (!conj-elim " (val->string goal) " " (val->string instantiated-parent) ")"]} }| | else => (error "Invalid application of conjunctive extraction tactic.")} @@ -241,13 +239,13 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise trivial-case := (join "assume h := " goal-str "\n (!claim h)"); process-disjunct := lambda (disjunct tail-end) check {(equal? disjunct goal) => ["\ncase-" (val->string (inc index)) " := " trivial-case tail-end] - | else => ["\ncase-" (val->string (inc index)) " := " marker tail-end]}; + | else => ["\ncase-" (val->string (inc index)) " := " (marker) tail-end]}; case-chunks := (flatten (join (map lambda (d) (process-disjunct d ";\n") (all-but-last disjuncts)) [(process-disjunct (last disjuncts) "\n")])); _ := (set! index 1)} - (join ["let {disjunction := " marker ";\n"] + (join ["let {disjunction := " (marker) ";\n"] case-chunks ["}\n (!cases disjunction " (separate (map lambda (_) @@ -259,17 +257,17 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise | (if antecedent (val-of goal)) => |{'tactic-info := ['if-> aux-info], - 'proof := ["let {cond := " marker ";\n ant := " marker "\n }\n (!mp cond ant)"], + 'proof := ["let {cond := " (marker) ";\n ant := " (marker) "\n }\n (!mp cond ant)"], 'subgoals := [instantiated-parent antecedent]}| | (iff left (val-of goal)) => |{'tactic-info := ['iff-left-> aux-info], - 'proof := ["let {bicond := " marker ";\n left := " marker "\n }\n (!mp (!left-iff bicond) left)"], + 'proof := ["let {bicond := " (marker) ";\n left := " (marker) "\n }\n (!mp (!left-iff bicond) left)"], 'subgoals := [instantiated-parent left]}| | (iff (val-of goal) right) => |{'tactic-info := ['iff-right-> aux-info], - 'proof := ["let {bicond := " marker ";\n right := " marker "\n }\n (!mp (!right-iff bicond) right)"], + 'proof := ["let {bicond := " (marker) ";\n right := " (marker) "\n }\n (!mp (!right-iff bicond) right)"], 'subgoals := [instantiated-parent right]}| | (forall (some-var v) (some-sentence _)) => @@ -277,7 +275,7 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise 'subgoals := let {_ := (print "\nINSTANTIATED PARENT: " instantiated-parent "\nAND PARENT: " parent)} [instantiated-parent], 'proof := let {theta' := (make-sub [[v (first (quant-vars parent))]])} - ["let {ugen := " marker "}\n (!uspec ugen " (val->string ((compose-subs theta theta') v)) ")"] + ["let {ugen := " (marker) "}\n (!uspec ugen " (val->string ((compose-subs theta theta') v)) ")"] }| } @@ -323,8 +321,8 @@ define case-analysis-tactic := disjuncts)); _ := (set! (goal-record 'tactic) ['case-analysis [disjunction]]); index := (cell 1); - _ := (set! (goal-record 'proof) (join ["let {disjunction := " marker "}\n " "(!cases disjunction\n "] - (map lambda (d) marker + _ := (set! (goal-record 'proof) (join ["let {disjunction := " (marker) "}\n " "(!cases disjunction\n "] + (map lambda (d) (marker) disjuncts) [")"])); counter := (cell 1); @@ -345,7 +343,7 @@ define contradiction-tactic := let {goal := (goal-record 'goal); goal-complement := (complement goal); _ := (set! (goal-record 'tactic) ['contradiction []]); - _ := (set! (goal-record 'proof) ["(!by-contradiction " (val->string goal) "\n assume " (val->string goal-complement) "\n " marker ")"]); + _ := (set! (goal-record 'proof) ["(!by-contradiction " (val->string goal) "\n assume " (val->string goal-complement) "\n " (marker) ")"]); new-goal-record := (make-child goal-record [['assumptions (add-all goal-complement (goal-record 'assumptions))] ['goal false]])} (add new-goal-record rest) | _ => (error "Invalid tactic application - there are no open goals currently.") @@ -394,7 +392,7 @@ define infer-tactic := _ := (print "\nGOT THIS LEMMA: " lemma); new-goal := (make-child goal-record [['assumptions (add-all lemma (goal-record 'assumptions))]]); _ := (set! (goal-record 'tactic) ['infer args]); - _ := (set! (goal-record 'proof) ["let {_ := " (unparse-body M) "}\n " marker]) + _ := (set! (goal-record 'proof) ["let {_ := " (unparse-body M) "}\n " (marker)]) } (add new-goal rest) | _ => (print "Invalid argument given to the infer tactic: A nullary method is expected.") @@ -556,13 +554,13 @@ define (apply-tactic* tactic-name args) := | _ => () } - +define (marker? str) := (&& (prefix? "**" str) (for-each (drop str 2) digit?)) define (show-proof) := letrec {join-proof-chunks := lambda (proof-chunks children-proofs res) match proof-chunks { [] => (flatten (join (rev res))) - | (list-of chunk more) => check {(&& (equal? chunk marker) (negate (null? children-proofs))) => + | (list-of chunk more) => check {(&& (marker? chunk) (negate (null? children-proofs))) => (join-proof-chunks more (tail children-proofs) (add (first children-proofs) res)) @@ -594,6 +592,8 @@ load "lib/basic/tactics" (print (show-proof)) +(clear-state) + assert c := (A & B) (set-goal (B & A)) (apply-tactic 'and<- []) From 239f97a62be6e4dd8e0e4442fadfebf6ad3bb9a0 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Wed, 23 Oct 2024 09:50:44 -0400 Subject: [PATCH 28/49] Implemented replace-strings in util.ath using naive split patterns --- lib/basic/util.ath | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lib/basic/util.ath b/lib/basic/util.ath index ec2e401..fe2a437 100644 --- a/lib/basic/util.ath +++ b/lib/basic/util.ath @@ -5160,4 +5160,11 @@ define hol-fun := lambda-promote define (unparse-body method-thunk) := let {str := (unparse method-thunk)} check {(prefix? "Method:" str) => (trim (all-but-last (drop str 18)) " ") - | else => (trim (all-but-last (drop str 10)) " ")} \ No newline at end of file + | else => (trim (all-but-last (drop str 10)) " ")} + +define (replace-string pat replacement base) := + match base { + (split (some-list L1) (val-of pat) (some-list L2)) => (replace-string pat replacement (join L1 replacement L2)) + | _ => base + } + \ No newline at end of file From 1f85921789057553ab1e138e8aa7c9a874eae107 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Wed, 23 Oct 2024 10:13:48 -0400 Subject: [PATCH 29/49] WIP --- lib/basic/tactics.ath | 36 ++++++++++++++++++++++++++++-------- lib/basic/util.ath | 6 ++++++ 2 files changed, 34 insertions(+), 8 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index f489990..474ce50 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -17,8 +17,11 @@ module Tactics { (join "**" (val->string (inc marker-counter))) lambda () (ref marker-counter)] - define marker-transformations := (HashTable.table 100) - + define marker-replacements := (HashTable.table 100) + # The table marker-replacements maps marker strings like "**25" to lists of [pat replacement] pairs. + # That way, instead of blindly replacing a marker string like "**25" by some deduction string D, + # we can first replace every occurrence of every 'pat' inside D by the corresponding 'replacement'. + # A record (or frame) on the goal stack has the following form: # |{ # 'goal := , @@ -150,11 +153,17 @@ define (backward-tactic goal-stack tactic-name args) := (add new-goal-record rest) | else => (error "Invalid backward tactic application to a disjunction.")} | (forall (some-list vars) (some-sentence body)) => - let {fresh-vars := (map lambda (v) (fresh-var (sort-of v) (var->string v)) vars); + let {_ := (mark `1); + fresh-vars := (map lambda (v) (fresh-var (sort-of v) (string->id (var->string v))) vars); + _ := (mark `2); subgoal := (replace-vars vars fresh-vars body); + _ := (mark `3); new-goal-record := (make-child goal-record [['goal subgoal]]); - proof-chunks := (join ["pick-any "] (map var->string vars) ["\n " (marker)])} - (error "Not yet implemented") + eigen-vars := (map var->string vars); + pat-replacement-pairs := (zip fresh-vars eigen-vars); + _ := (HashTable.add marker-replacements [(current-marker-counter) pat-replacement-pairs]); + proof-chunks := (join ["pick-any "] eigen-vars ["\n " (marker)])} + (add new-goal-record rest) | _ => goal-stack } | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") @@ -438,6 +447,7 @@ define tactic-dictionary := 'if<- := lambda (goal-stack args) (backward-tactic goal-stack 'if<- args), 'iff<- := lambda (goal-stack args) (backward-tactic goal-stack 'iff<- args), 'and<- := lambda (goal-stack args) (backward-tactic goal-stack 'and<- args), + 'forall<- := lambda (goal-stack args) (backward-tactic goal-stack 'forall<- args), 'extract := extraction-tactic, 'infer := infer-tactic, 'contradiction := contradiction-tactic, @@ -451,6 +461,7 @@ define tactic-dictionary := | (or (some-list _)) => (backward-tactic goal-stack 'back args) | (if _ _) => (backward-tactic goal-stack 'if<- args) | (iff _ _) => (backward-tactic goal-stack 'iff<- args) + | (forall (some-list _) _) => (backward-tactic goal-stack 'forall<- args) | _ => (error "Invalid application of 'back - no backward tactic is applicable to the this goal") } | _ => goal-stack @@ -561,9 +572,12 @@ define (show-proof) := match proof-chunks { [] => (flatten (join (rev res))) | (list-of chunk more) => check {(&& (marker? chunk) (negate (null? children-proofs))) => - (join-proof-chunks more - (tail children-proofs) - (add (first children-proofs) res)) + let {proof := (first children-proofs); + pat-replacement-pairs := try {(HashTable.lookup marker-replacements chunk) | []}; + proof' := (replace-strings pat-replacement-pairs proof)} + (join-proof-chunks more + (tail children-proofs) + (add proof' res)) | else => (join-proof-chunks more children-proofs (add chunk res))} }; compose-proof := lambda (goal-record) @@ -587,6 +601,12 @@ open Tactics EOF load "lib/basic/tactics" +(assert (forall x . P x & Q x)) +(set-goal (forall x . Q x)) + +# qqq !!!! FIX: This works: (apply-tactic 'back []) but this gives an infinite loop: (apply-tactic* 'back []) + + (set-goal (A & B <==> B & A)) (apply-tactic* 'back []) diff --git a/lib/basic/util.ath b/lib/basic/util.ath index fe2a437..e766901 100644 --- a/lib/basic/util.ath +++ b/lib/basic/util.ath @@ -5167,4 +5167,10 @@ define (replace-string pat replacement base) := (split (some-list L1) (val-of pat) (some-list L2)) => (replace-string pat replacement (join L1 replacement L2)) | _ => base } + +define (replace-strings pat-replacement-pairs base) := + match pat-replacement-pairs { + (list-of [pat replacement] rest) => (replace-strings rest (replace-string pat replacement base)) + | _ => base + } \ No newline at end of file From 0fbb3ed896d3210fd026cd3f43f3896d97fe2752 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Wed, 23 Oct 2024 12:13:01 -0400 Subject: [PATCH 30/49] Restricted overly persmissive (forall (some-list vars) body) pattern in backward-tactic --- lib/basic/tactics.ath | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 474ce50..8e91094 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -152,19 +152,22 @@ define (backward-tactic goal-stack tactic-name args) := _ := (set! (goal-record 'proof) proof-chunks)} (add new-goal-record rest) | else => (error "Invalid backward tactic application to a disjunction.")} - | (forall (some-list vars) (some-sentence body)) => - let {_ := (mark `1); - fresh-vars := (map lambda (v) (fresh-var (sort-of v) (string->id (var->string v))) vars); - _ := (mark `2); + | (forall (vars as (list-of _ _)) (some-sentence body)) => + let {fresh-vars := (map lambda (v) (fresh-var (sort-of v) (string->id (var->string v))) vars); subgoal := (replace-vars vars fresh-vars body); - _ := (mark `3); new-goal-record := (make-child goal-record [['goal subgoal]]); eigen-vars := (map var->string vars); - pat-replacement-pairs := (zip fresh-vars eigen-vars); - _ := (HashTable.add marker-replacements [(current-marker-counter) pat-replacement-pairs]); - proof-chunks := (join ["pick-any "] eigen-vars ["\n " (marker)])} + pat-replacement-pairs := (zip (map val->string fresh-vars) + eigen-vars); + cm := (join "**" (val->string (current-marker-counter))); + _ := (print "\nCurrent marker counter: " cm); + _ := (HashTable.add marker-replacements [cm pat-replacement-pairs]); + _ := (print "\n pat-replacement-pairs:\n" pat-replacement-pairs); + proof-chunks := (join ["pick-any "] eigen-vars ["\n " (marker)]); + _ := check {(for-each proof-chunks string?) => (print "\nOK Chunks...") | else => (print "\nNON-STRING chunk...")}; + _ := (set! (goal-record 'proof) proof-chunks)} (add new-goal-record rest) - | _ => goal-stack + | _ => (error "Error: No backward tactic applicable.") } | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") } @@ -418,9 +421,7 @@ define (go-back-to goal-stack target-path) := [] => current-goal-record | (list-of index more) => (navigate-to (nth index (ref (current-goal-record 'children))) more) }} - try {let {_ := (mark `1); - target-goal := (navigate-to (ref root-goal) target-path); - _ := (mark `2); + try {let {target-goal := (navigate-to (ref root-goal) target-path); _ := (set! (target-goal 'children) []); _ := (set! (target-goal 'tactic) []); _ := (set! (target-goal 'proof) "")} @@ -603,6 +604,9 @@ EOF load "lib/basic/tactics" (assert (forall x . P x & Q x)) (set-goal (forall x . Q x)) +(apply-tactic 'back []) +(apply-tactic* 'extract [(forall x . P x & Q x)]) +(print (show-proof)) # qqq !!!! FIX: This works: (apply-tactic 'back []) but this gives an infinite loop: (apply-tactic* 'back []) From 1eaf983734376c49eb93200bf6c091271f6744cf Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Wed, 23 Oct 2024 12:45:40 -0400 Subject: [PATCH 31/49] Implemented exists<- --- lib/basic/tactics.ath | 29 ++++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 8e91094..1b7c922 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -164,9 +164,21 @@ define (backward-tactic goal-stack tactic-name args) := _ := (HashTable.add marker-replacements [cm pat-replacement-pairs]); _ := (print "\n pat-replacement-pairs:\n" pat-replacement-pairs); proof-chunks := (join ["pick-any "] eigen-vars ["\n " (marker)]); - _ := check {(for-each proof-chunks string?) => (print "\nOK Chunks...") | else => (print "\nNON-STRING chunk...")}; _ := (set! (goal-record 'proof) proof-chunks)} (add new-goal-record rest) + | (exists (vars as (list-of _ _)) (some-sentence body)) => + let {_ := (mark `1)} + match args { + [((some-list witnesses) where (&& (for-each witnesses term?) (equal? (length witnesses) (length vars))))] => + let {_ := (mark `2); + subgoal := (replace-vars vars witnesses body); + new-goal-record := (make-child goal-record [['goal subgoal]]); + proof-chunks := (join ["let {_ := " (marker) "}\n " "(!egen* " (val->string goal) " ["] + [(separate (map val->string witnesses) " ")] + ["])"]); + _ := (set! (goal-record 'proof) proof-chunks)} + (add new-goal-record rest) + } | _ => (error "Error: No backward tactic applicable.") } | _ => (error "Error: Attempt to apply the backward tactic to an empty goal stack.") @@ -449,6 +461,7 @@ define tactic-dictionary := 'iff<- := lambda (goal-stack args) (backward-tactic goal-stack 'iff<- args), 'and<- := lambda (goal-stack args) (backward-tactic goal-stack 'and<- args), 'forall<- := lambda (goal-stack args) (backward-tactic goal-stack 'forall<- args), + 'exists<- := lambda (goal-stack args) (backward-tactic goal-stack 'exists<- args), 'extract := extraction-tactic, 'infer := infer-tactic, 'contradiction := contradiction-tactic, @@ -462,8 +475,9 @@ define tactic-dictionary := | (or (some-list _)) => (backward-tactic goal-stack 'back args) | (if _ _) => (backward-tactic goal-stack 'if<- args) | (iff _ _) => (backward-tactic goal-stack 'iff<- args) - | (forall (some-list _) _) => (backward-tactic goal-stack 'forall<- args) - | _ => (error "Invalid application of 'back - no backward tactic is applicable to the this goal") + | (forall (list-of _ _) _) => (backward-tactic goal-stack 'forall<- args) + | (exists (list-of _ _) _) => (backward-tactic goal-stack 'exists<- args) + | _ => (error "Invalid application of 'back - no backward tactic is applicable to this goal") } | _ => goal-stack }, @@ -595,6 +609,7 @@ declare A, B, C, D, E: Boolean declare zero:Int declare succ: [Int] -> Int declare P, Q, pos, T: [Int] -> Boolean +declare R: [Int Int] -> Boolean declare a, b, c: Int open Tactics @@ -602,6 +617,14 @@ open Tactics EOF load "lib/basic/tactics" + +(assert p := (1 R succ 2)) +(set-goal (exists x y . x R succ y)) +(apply-tactic 'exists<- [[1 2]]) + + + +(clear-state) (assert (forall x . P x & Q x)) (set-goal (forall x . Q x)) (apply-tactic 'back []) From ac698d0e8d17d7a41b7f9be59a2ef46b626c5774 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Thu, 24 Oct 2024 09:25:29 -0400 Subject: [PATCH 32/49] Ensuring that a goal's tactic info is not set prematurely. --- lib/basic/tactics.ath | 49 ++++++++++++++++++++++++++++++------------- 1 file changed, 34 insertions(+), 15 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 1b7c922..26777aa 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -76,20 +76,30 @@ define (make-child goal-record new-child-bindings) := child -define (leaf? goal-record) := (&& (null? (ref (goal-record 'children))) (unequal? (ref (goal-record 'tactic)) [])) +define (find-instance p props) := +# Viewing p as a pattern, find some sentence q in props that matches (is an instance of) p, and return the corresponding substitution. +# If no such q exists, return (). + () + +define (leaf? goal-record) := + (&& (null? (ref (goal-record 'children))) + (unequal? (ref (goal-record 'tactic)) [])) define (make-subgoals goal subgoals) := let {make-subgoal := lambda (p index) (make-child goal [['goal p] ['path (extend-path goal index)]]); counter := (cell 1)} (map lambda (p) (make-subgoal p (inc counter)) subgoals) - + +define (set-proof-and-tactic-info goal-record tactic-name args proof-chunks) := + (seq (set! (goal-record 'tactic) [tactic-name args]) + (set! (goal-record 'proof) proof-chunks)) + define (backward-tactic goal-stack tactic-name args) := # This essentially ignores tactic-name for all cases except disjunctions. What if a tactic like 'and<- is applied to a conditional? match goal-stack { (list-of goal-record rest) => - let {_ := (set! (goal-record 'tactic) [tactic-name args]); - goal := (goal-record 'goal)} + let {goal := (goal-record 'goal)} match goal { (and (some-list _)) => let {conjuncts := (get-conjuncts goal); @@ -107,18 +117,18 @@ define (backward-tactic goal-stack tactic-name args) := conjuncts)) " ")] ["])"])) }; - _ := (set! (goal-record 'proof) proof-chunks)} + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} new-stack | (if (some-sentence p) (some-sentence q)) => let {goal-record' := (make-child goal-record [['goal q] ['assumptions (add-all p (goal-record 'assumptions))]]); proof-chunks := [(join "assume " (val->string p) "\n ") (marker)]; - _ := (set! (goal-record 'proof) proof-chunks)} + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} (add goal-record' rest) | (iff (some-sentence p) (some-sentence q)) => let {goal-record' := (make-child goal-record [['goal (and (if p q) (if q p))]]); proof-chunks := ["let {biconditional := " (marker) "}\n (!equiv (!left-and biconditional) (!right-and biconditional))"]; - _ := (set! (goal-record 'proof) proof-chunks)} + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} (add goal-record' rest) | (or (some-list _)) => let {disjuncts := (get-disjuncts goal)} @@ -131,7 +141,7 @@ define (backward-tactic goal-stack tactic-name args) := | else => [q "right-either "]}; new-goal-record := (make-child goal-record [['goal new-goal]]); proof-chunks := ["let {_ := " (marker) "}\n " (join "(!" method-name (val->string p) " " (val->string q) ")")]; - _ := (set! (goal-record 'proof) proof-chunks)} + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} (add new-goal-record rest) | _ => (error (join "Invalid application of " tactic-name))} | (&& (member? tactic-name ['back 'or<-]) (null? args)) => @@ -141,7 +151,7 @@ define (backward-tactic goal-stack tactic-name args) := lambda (d) let {new-goal-record := (make-child goal-record [['goal d]]); proof-chunks := ["let {_ := " (marker) "}\n " (join "(!either " (val->string goal) ")")]; - _ := (set! (goal-record 'proof) proof-chunks)} + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} (add new-goal-record rest) lambda () (error "Invalid application of 'back to a disjunction.")) @@ -149,7 +159,7 @@ define (backward-tactic goal-stack tactic-name args) := let {subgoal := (first args); new-goal-record := (make-child goal-record [['goal subgoal]]); proof-chunks := ["let {_ := " (marker) "}\n " (join "(!either " (val->string goal) ")")]; - _ := (set! (goal-record 'proof) proof-chunks)} + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} (add new-goal-record rest) | else => (error "Invalid backward tactic application to a disjunction.")} | (forall (vars as (list-of _ _)) (some-sentence body)) => @@ -164,10 +174,9 @@ define (backward-tactic goal-stack tactic-name args) := _ := (HashTable.add marker-replacements [cm pat-replacement-pairs]); _ := (print "\n pat-replacement-pairs:\n" pat-replacement-pairs); proof-chunks := (join ["pick-any "] eigen-vars ["\n " (marker)]); - _ := (set! (goal-record 'proof) proof-chunks)} + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} (add new-goal-record rest) | (exists (vars as (list-of _ _)) (some-sentence body)) => - let {_ := (mark `1)} match args { [((some-list witnesses) where (&& (for-each witnesses term?) (equal? (length witnesses) (length vars))))] => let {_ := (mark `2); @@ -176,8 +185,15 @@ define (backward-tactic goal-stack tactic-name args) := proof-chunks := (join ["let {_ := " (marker) "}\n " "(!egen* " (val->string goal) " ["] [(separate (map val->string witnesses) " ")] ["])"]); - _ := (set! (goal-record 'proof) proof-chunks)} - (add new-goal-record rest) + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} + (add new-goal-record rest) + # If no instantiating term is specified, then try to find one: + | [] => match (find-instance body (join (goal-record 'assumptions) (ab))) { + (some-sub theta) => let {witnesses := (theta vars)} + (backward-tactic goal-stack tactic-name [witnesses]) + | _ => (error "Invalid application of exists<-: No witnesses specified and none could be found.") + } + | _ => (error "Error: Invalid application of exists<-: A (possibly empty) list of witnesses was expected as the tactic argument.") } | _ => (error "Error: No backward tactic applicable.") } @@ -451,7 +467,7 @@ define go-back-tactic := } | _ => (error "Invalid tactic application - there are no open goals currently.") } - + define tactic-dictionary := |{ 'lor<- := lambda (goal-stack args) (backward-tactic goal-stack 'lor<- args), @@ -620,6 +636,9 @@ load "lib/basic/tactics" (assert p := (1 R succ 2)) (set-goal (exists x y . x R succ y)) + +(apply-tactic 'exists<- []) + (apply-tactic 'exists<- [[1 2]]) From 06dde6615601ed54f83d0d867da19c72a4566fd5 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Thu, 24 Oct 2024 09:48:46 -0400 Subject: [PATCH 33/49] Search-based version of exists<- working --- lib/basic/tactics.ath | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 26777aa..53cfef7 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -78,9 +78,13 @@ define (make-child goal-record new-child-bindings) := define (find-instance p props) := # Viewing p as a pattern, find some sentence q in props that matches (is an instance of) p, and return the corresponding substitution. -# If no such q exists, return (). - () - +# If no such q exists, return false. + (find-element' props + substitution? + lambda (q) (match-props q p) + lambda (res) res + lambda () false) + define (leaf? goal-record) := (&& (null? (ref (goal-record 'children))) (unequal? (ref (goal-record 'tactic)) [])) @@ -635,9 +639,9 @@ EOF load "lib/basic/tactics" (assert p := (1 R succ 2)) -(set-goal (exists x y . x R succ y)) +(set-goal (exists x . x R succ 2)) -(apply-tactic 'exists<- []) +(apply-tactic 'exists<- [[1]]) (apply-tactic 'exists<- [[1 2]]) From a48616ea774482f1004752914279f95acca8826d Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Thu, 24 Oct 2024 10:04:53 -0400 Subject: [PATCH 34/49] Implemented separated-markers --- lib/basic/tactics.ath | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 53cfef7..4319df6 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -349,7 +349,13 @@ define extraction-tactic := }} } } - + +define (separated-markers N) := + letrec {loop := lambda (i res) + check {(less? i 2) => (rev (add (marker) res)) + | else => (loop (minus i 1) (add " " (add (marker) res)))}} + (loop N []) + define case-analysis-tactic := lambda (goal-stack args) # We must return a new goal stack. @@ -366,8 +372,8 @@ define case-analysis-tactic := _ := (set! (goal-record 'tactic) ['case-analysis [disjunction]]); index := (cell 1); _ := (set! (goal-record 'proof) (join ["let {disjunction := " (marker) "}\n " "(!cases disjunction\n "] - (map lambda (d) (marker) - disjuncts) + #(map lambda (d) (join (marker) " ") (all-but-last disjuncts)) qqq + (separated-markers (length disjuncts)) [")"])); counter := (cell 1); new-goal-records' := (map lambda (subgoal) From 236fd59c47c048a76f0eefe5508fb6f27892f101 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Thu, 24 Oct 2024 11:13:08 -0400 Subject: [PATCH 35/49] New generalized case analysis, and argument-less extractions --- lib/basic/polarities.ath | 19 +++----- lib/basic/tactics.ath | 97 +++++++++++++++++++++++++++------------- 2 files changed, 72 insertions(+), 44 deletions(-) diff --git a/lib/basic/polarities.ath b/lib/basic/polarities.ath index 9910fcd..6da35e9 100644 --- a/lib/basic/polarities.ath +++ b/lib/basic/polarities.ath @@ -97,17 +97,6 @@ define (sub-sentence-map p) := }} (loop p [] 'p |{}|) - -define (positive-in-ab? p props) := - let {F := lambda () false; - S := lambda (_) true} - (find-element props - lambda (q) - let {M := (sub-sentence-map q)} - try {let {_ := (M p)} true | false } - S - F) - define (polarities-and-positions p q) := let {prepend-and-process := lambda (i f) @@ -257,7 +246,13 @@ define (find-proper-matches* r props) := } }} (loop props []) - + +define (positive-in-ab? p props) := + match (find-proper-matches* p props) { + [] => false + | _ => true + } + define (ufv p subsentence-position) := # This computes UFV(q,p) where q is the unique subsentence of p at subsentence-position: let {p-fvars := (fv p); diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 4319df6..5ab9c7a 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -217,6 +217,13 @@ define (show-stack) := (ref goal-stack)) (print "\n\n]]]]]]]]]]]]]\n")) +define (holds-in p goal-record) := + (|| (holds? p) (member? p (goal-record 'assumptions))) + +define (fails-in p goal-record) := (negate (holds-in p goal-record)) + +define (hold-in props goal-record) := (for-each props lambda (p) (holds-in p goal-record)) + define set-goal := lambda (goal-sentence) check {(holds? goal-sentence) => (print "\nThis sentence already holds.") @@ -331,9 +338,13 @@ define extraction-tactic := match goal-stack { (list-of goal-record rest) => match [(goal-record 'goal) args] { - # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: - [goal [premise]] => check {(negate (|| (member? premise (goal-record 'assumptions)) - (holds? premise))) => (error "Invalid application of the extraction tactic: the given premise does not hold:\n" premise) + # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: + [goal []] => # If no premise is specified, try to find one: + (find-element (join (ab) (goal-record 'assumptions)) + lambda (premise) (unequal? (Polarities.find-universally-positive-parent goal premise) ()) + lambda (premise) (extraction-tactic goal-stack [premise]) + lambda () (error "Invalid application of extraction: the given goal does not have any universally positive parents in the current assumptions.")) + | [goal [premise]] => check {(premise fails-in goal-record) => (error (join "Invalid application of the extraction tactic: the given premise does not hold:\n" (val->string premise))) | else => match (Polarities.find-universally-positive-parent goal premise) { () => (error "Invalid application of the extraction tactic: the given premise does not have any universally positive occurrences of a goal parent") | [(some-sentence parent) parent-position-in-premise theta] => @@ -363,28 +374,31 @@ define case-analysis-tactic := match goal-stack { (list-of goal-record rest) => match [(goal-record 'goal) args] { - # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: - [goal [(disjunction as (or (some-list _)))]] => - let {disjuncts := (get-disjuncts disjunction)} - check {(Polarities.positive-in-ab? disjunction (join (ab) (goal-record 'assumptions))) => - let {subgoals := (add disjunction (map lambda (disjunct) (if disjunct goal) - disjuncts)); - _ := (set! (goal-record 'tactic) ['case-analysis [disjunction]]); - index := (cell 1); - _ := (set! (goal-record 'proof) (join ["let {disjunction := " (marker) "}\n " "(!cases disjunction\n "] - #(map lambda (d) (join (marker) " ") (all-but-last disjuncts)) qqq - (separated-markers (length disjuncts)) - [")"])); - counter := (cell 1); - new-goal-records' := (map lambda (subgoal) - (make-child goal-record [['goal subgoal] ['path (extend-path goal-record (inc counter))]]) - subgoals)} - (join new-goal-records' rest) - | else => (error "Invalid application of the case-analysis tactic: the given disjunction is not positively embedded in the current a.b.") - } + # We need to extract goal from premise, but first we must verify that the goal is positively embedded in the premise: + [goal [(disjunction as (or (some-list _)))]] => + let {_ := (mark `0)} + match (Polarities.find-proper-matches* disjunction (join (ab) (goal-record 'assumptions))) { + (list-of (some-map D) _) => + let {_ := (mark `1); + theta := (D 'theta); + disjuncts := (get-disjuncts disjunction); + subgoals := (add disjunction (map lambda (disjunct) (if disjunct goal) + disjuncts)); + _ := (set! (goal-record 'tactic) ['case-analysis [disjunction]]); + index := (cell 1); + _ := (set! (goal-record 'proof) (join ["let {disjunction := " (marker) "}\n " "(!cases disjunction\n "] + (separated-markers (length disjuncts)) + [")"])); + counter := (cell 1); + new-goal-records' := (map lambda (subgoal) + (make-child goal-record [['goal subgoal] ['path (extend-path goal-record (inc counter))]]) + subgoals)} + (join new-goal-records' rest) + | _ => (error "Invalid application of the case-analysis tactic: the given disjunction is not positively embedded in the current a.b.") + } } } - + define contradiction-tactic := lambda (goal-stack _) # We must return a new goal stack. @@ -398,13 +412,6 @@ define contradiction-tactic := (add new-goal-record rest) | _ => (error "Invalid tactic application - there are no open goals currently.") } - -define (holds-in p goal-record) := - (|| (holds? p) (member? p (goal-record 'assumptions))) - -define (fails-in p goal-record) := (negate (holds-in p goal-record)) - -define (hold-in props goal-record) := (for-each props lambda (p) (holds-in p goal-record)) define from-complements-tactic := lambda (goal-stack args) @@ -634,7 +641,7 @@ declare A, B, C, D, E: Boolean declare zero:Int declare succ: [Int] -> Int -declare P, Q, pos, T: [Int] -> Boolean +declare P, Q, pos, S, T: [Int] -> Boolean declare R: [Int Int] -> Boolean declare a, b, c: Int @@ -643,6 +650,25 @@ open Tactics EOF load "lib/basic/tactics" +assert p1 := (forall x . P x | Q x) +assert p2 := (forall x . P x ==> S x) +assert p3 := (forall x . Q x ==> S x) +(set-goal (S a)) + +(apply-tactic 'case-analysis [(P a | Q a)]) +(apply-tactic* 'extract []) + +(apply-tactic 'extract []) + +(apply-tactic 'extract [p1]) + +(apply-tactic 'extract [p2]) +(apply-tactic 'extract [p3]) + + + +(apply-tactic 'case-analysis [(P a | Q a)]) + (assert p := (1 R succ 2)) (set-goal (exists x . x R succ 2)) @@ -689,9 +715,16 @@ assert c := B assert d := (A | B | C) assert con := (and (if A D) (if B D) (if C D)) (set-goal D) - (apply-tactic 'case-analysis [d]) + +assert p1 := (forall x . P x | Q x) +assert p2 := (forall x . P x ==> S x) +assert p3 := (forall x . Q x ==> S x) +(set-goal (S a)) +(apply-tactic 'case-analysis [(P a | Q a)]) + + assert p1 := (A ==> B & C) assert p2 := (~ B) (set-goal (not A)) From 8929c85960d067b911f8ac015c534c8217e918ab Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Fri, 25 Oct 2024 10:14:05 -0400 Subject: [PATCH 36/49] Implemented 'exists->, the pick-witness tactic. --- lib/basic/tactics.ath | 69 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 61 insertions(+), 8 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 5ab9c7a..2a91fbf 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -28,7 +28,7 @@ module Tactics { # 'id := , # 'path := , # 'assumptions := , - # 'eigenvariables := , + # 'eigenvars := , # 'witnesses := , # 'parent := , # 'children := , @@ -169,7 +169,6 @@ define (backward-tactic goal-stack tactic-name args) := | (forall (vars as (list-of _ _)) (some-sentence body)) => let {fresh-vars := (map lambda (v) (fresh-var (sort-of v) (string->id (var->string v))) vars); subgoal := (replace-vars vars fresh-vars body); - new-goal-record := (make-child goal-record [['goal subgoal]]); eigen-vars := (map var->string vars); pat-replacement-pairs := (zip (map val->string fresh-vars) eigen-vars); @@ -178,7 +177,8 @@ define (backward-tactic goal-stack tactic-name args) := _ := (HashTable.add marker-replacements [cm pat-replacement-pairs]); _ := (print "\n pat-replacement-pairs:\n" pat-replacement-pairs); proof-chunks := (join ["pick-any "] eigen-vars ["\n " (marker)]); - _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks)} + _ := (set-proof-and-tactic-info goal-record tactic-name args proof-chunks); + new-goal-record := (make-child goal-record [['goal subgoal] ['eigenvars (join fresh-vars (goal-record 'eigenvars))]])} (add new-goal-record rest) | (exists (vars as (list-of _ _)) (some-sentence body)) => match args { @@ -207,7 +207,7 @@ define (backward-tactic goal-stack tactic-name args) := define (show-goal-record g i N) := (print "\n\n****************************** Stack record" i "out of" N "\n--Goal: " (g 'goal) "\n--Goal id: " (g 'id) "\n--Path: " (g 'path) - "\n--Assumptions:\n" (g 'assumptions) "\n--Eigenvariables: " (g 'eigenvariables) "\n--Witnesses: " (g 'witnesses)) + "\n--Assumptions:\n" (g 'assumptions) "\n--Eigenvariables: " (g 'eigenvars) "\n--Witnesses: " (g 'witnesses)) define (show-stack) := let {counter := (cell 1); @@ -232,7 +232,7 @@ define set-goal := 'path := [], 'goal := goal-sentence, 'assumptions := [], - 'eigenvariables := [], + 'eigenvars := [], 'witnesses := [], 'parent := (), 'tactic := (cell []), @@ -432,7 +432,45 @@ define from-complements-tactic := | _ => (error "Invalid tactic application - there are no open goals currently.") } - + +define pick-witness-tactic := + lambda (goal-stack args) + # We must return a new goal stack. + let {_ := (print "\nInside the from-complements tactic, here's args: " args "\nand here is the goal stack: " goal-stack)} + match goal-stack { + (list-of goal-record rest) => + match [(goal-record 'goal) args] { + [goal []] => (error "Empty argument lists for exists-> are not supported yet.") + | [goal [(existential-sentence as (exists (some-var v) (some-sentence body)))]] => + match (Polarities.find-proper-matches* existential-sentence (join (ab) (goal-record 'assumptions))) { + [] => (error "Incorrect application of 'exists->: The given existential quantification is not positively embedded in the current set of assumptions.") + | (list-of (some-map D) _) => + let {subgoal := existential-sentence; + witness-var := (fresh-var (sort-of v) 'witness); + witness-marker := (marker); + pat-replacement-pairs := [[(val->string witness-var) "w"]]; + cm := (join "**" (val->string (current-marker-counter))); + _ := (HashTable.add marker-replacements [cm pat-replacement-pairs]); + _ := (print "\nCurrent marker counter: " cm); + _ := (print "\n pat-replacement-pairs:\n" pat-replacement-pairs); + witness-body := (replace-var v witness-var body); + _ := (print "\nWITNESS BODY:\n" witness-body); + new-goal-record-1 := (make-child goal-record [['goal subgoal]]); + new-goal-record-2 := (make-child goal-record [['assumptions (add-all witness-body (goal-record 'assumptions))] + ['witnesses (add witness-var (goal-record 'witnesses))]]); + proof-chunks := (join ["let {_ := " witness-marker "}\n "] + ["pick-witness w for "] + [(val->string existential-sentence)] + ["\n "] + [(marker)]); + _ := (set-proof-and-tactic-info goal-record 'exists-> args proof-chunks)} + (join [new-goal-record-1 new-goal-record-2] rest) + } + | _ => (error "The exists-> tactic expects an existential quantification as its sole argument, or else no arguments at all.") + } + | _ => (error "Invalid tactic application - there are no open goals currently.") + } + define (execute-thunk M assumptions) := let {p := assume (and assumptions) (!M)} (consequent p) @@ -494,7 +532,8 @@ define tactic-dictionary := 'iff<- := lambda (goal-stack args) (backward-tactic goal-stack 'iff<- args), 'and<- := lambda (goal-stack args) (backward-tactic goal-stack 'and<- args), 'forall<- := lambda (goal-stack args) (backward-tactic goal-stack 'forall<- args), - 'exists<- := lambda (goal-stack args) (backward-tactic goal-stack 'exists<- args), + 'exists<- := lambda (goal-stack args) (backward-tactic goal-stack 'exists<- args), + 'exists-> := pick-witness-tactic, 'extract := extraction-tactic, 'infer := infer-tactic, 'contradiction := contradiction-tactic, @@ -650,6 +689,20 @@ open Tactics EOF load "lib/basic/tactics" +assert p1 := (forall x . P x ==> Q x) +assert p2 := (exists x . P x) +(set-goal (exists x . Q x)) +(apply-tactic 'exists-> [p2]) +(apply-tactic 'exists<- [[?witness964:Int]]) +(apply-tactic* 'extract []) + +(print (show-proof)) + + + +(apply-tactic 'infer [method () (!uspec p1 ?witness964:Int)]) + + assert p1 := (forall x . P x | Q x) assert p2 := (forall x . P x ==> S x) assert p3 := (forall x . Q x ==> S x) @@ -683,7 +736,7 @@ assert p3 := (forall x . Q x ==> S x) (assert (forall x . P x & Q x)) (set-goal (forall x . Q x)) (apply-tactic 'back []) -(apply-tactic* 'extract [(forall x . P x & Q x)]) +(apply-tactic* 'extract []) (print (show-proof)) # qqq !!!! FIX: This works: (apply-tactic 'back []) but this gives an infinite loop: (apply-tactic* 'back []) From 6423376b7e9c5b030a3cf9075c3dda7923be3714 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Fri, 25 Oct 2024 11:33:45 -0400 Subject: [PATCH 37/49] WIP --- lib/basic/polarities.ath | 87 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 86 insertions(+), 1 deletion(-) diff --git a/lib/basic/polarities.ath b/lib/basic/polarities.ath index 6da35e9..8f45972 100644 --- a/lib/basic/polarities.ath +++ b/lib/basic/polarities.ath @@ -217,7 +217,92 @@ define (get-conjuncts-and-their-positions p) := (print "\nAnd the parent's position: ") (writeln-val q-parent-pos) (print "]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]"))))) - +define (all-universal-occurrences r p positive?) := +# This will return a list of all *universal* occurrences of a generalized version of r, call it q, inside p. +# By a generalized version we mean that r must match q under some theta. The positive? boolean flag determines +# whether the returned occurrences are positive in p (or negative, respectively). Thus, +# (find-universal-occurrences (Q a) (forall x . P x & Q x) true) should return [2 2] under {?x -> a} as the +# sole match, but (find-universal-occurrences (Q a) (forall x . P x & Q x) false) would be asking for universally +# negative occurrences of (Q a) inside the base (forall x . P x & Q x), and there are no such occurrences, so +# in that case the empty list should be returned. + let {prohibited-polarity? := lambda (pol) + check {positive? => (negative-pol? pol) + | else => (positive-pol? pol)}} + letrec {loop := lambda (q q-pos q-pol) + match (match-props r q) { + (some-sub theta) => check {(prohibited-polarity? q-pol) => [] + | else => [|{'matching-subsentence := q, 'matching-pos := (rev q-pos), 'theta := theta, 'base-sentence := p}|]} + | _ => match q { + (not q') => (loop q' (add 1 q-pos) (flip q-pol)) + + | (if q1 q2) => (join (loop q1 (add 1 q-pos) (flip q-pol)) + (loop q2 (add 2 q-pos) q-pol)) + | (iff q1 q2) => (join (loop q1 (add 1 q-pos) 'pn) + (loop q2 (add 2 q-pos) 'pn)) + | (and (some-list _)) => let {conjuncts-and-their-positions := (get-conjuncts-and-their-positions q)} + (flatten (map lambda (conjunct-and-its-position) + let {[q_i q_i_pos] := conjunct-and-its-position} + (loop q_i q_i_pos q-pol) + conjuncts-and-their-positions)) + | (or (some-list _)) => let {disjuncts-and-their-positions := (get-disjuncts-and-their-positions q)} + (flatten (map lambda (disjunct-and-its-position) + let {[q_i q_i_pos] := disjunct-and-its-position} + (loop q_i q_i_pos q-pol) + disjuncts-and-their-positions)) + | (forall (some-var _) (some-sentence body)) => + check {(negative-pol? q-pol) => [] + | else => (loop body (add 2 q-pos) q-pol)} + | ((|| exists exists-unique) (some-var _) (some-sentence body)) => + check {(positive-pol? q-pol) => [] + | else => (loop body (add 2 q-pos) q-pol)} + | _ => [] + } + }} + (loop p [] 'p) + +define (all-universally-positive-occurrences r p) := (all-universal-occurrences r p true) + +define (all-universally-negative-occurrences r p) := (all-universal-occurrences r p false) + +define (all-universally-positive-occurrences* r props) := + (flatten (map lambda (p) + (all-universally-positive-occurrences r p) + props)) + +define (find-universally-positive-occurrence target base) := +# If there are no universally positive occurrences of the given target in base, then this will return (). + match (all-universally-positive-occurrences target base) { + (list-of (some-map D) _) => D + | _ => () + } + +define (find-universally-negative-occurrence target base) := +# If there are no universally negative occurrences of the given target in base, then this will return (). + match (all-universally-negative-occurrences target base) { + (list-of (some-map D) _) => D + | _ => () + } + +define (find-universally-positive-occurrence* target props) := +# Find the *first* match among all props. If there are none, return (): + (find-element' + props + lambda (D) + (unequal? D ()) + lambda (p) (find-universally-positive-occurrence target p) + lambda (x) x + lambda () ()) + +define (find-universally-negative-occurrence* target props) := +# Find the *first* match among all props. If there are none, return (): + (find-element' + props + lambda (D) + (unequal? D ()) + lambda (p) (find-universally-negative-occurrence target p) + lambda (x) x + lambda () ()) + define (list->sub result) := match result { [q q-pos theta q-parent q-parent-pos _] => From bf4fed5eaf0ba254badd7920359b7829e36a1bdb Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Sat, 26 Oct 2024 10:30:44 -0400 Subject: [PATCH 38/49] Implemented exists-> --- lib/basic/tactics.ath | 65 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 59 insertions(+), 6 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 2a91fbf..4addc0b 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -318,9 +318,19 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise | (iff (val-of goal) right) => |{'tactic-info := ['iff-right-> aux-info], - 'proof := ["let {bicond := " (marker) ";\n right := " (marker) "\n }\n (!mp (!right-iff bicond) right)"], - 'subgoals := [instantiated-parent right]}| - + 'proof := ["let {bicond := " (marker) ";\n right := " (marker) "\n }\n (!mp (!right-iff bicond) right)"], + 'subgoals := [instantiated-parent right]}| + + | (not (some-sentence body)) => + # If the parent is the negation of the goal, but the parent itself is negated, then + let {grand-parent := (Polarities.subprop premise (all-but-last parent-position-in-premise))} + check {(&& (non-empty? parent-position-in-premise) + (equals? (root grand-parent) not)) => + |{'tactic-info := ['not-> aux-info], + 'subgoals := [grand-parent], + 'proof := ["let {doubly-negated-goal := " (marker) "}\n (!dn doubly-negated-goal)"]}| + | else => (error "Invalid application of not->")} + | (forall (some-var v) (some-sentence _)) => |{'tactic-info := ['forall3-> aux-info], 'subgoals := let {_ := (print "\nINSTANTIATED PARENT: " instantiated-parent "\nAND PARENT: " parent)} @@ -466,6 +476,32 @@ define pick-witness-tactic := _ := (set-proof-and-tactic-info goal-record 'exists-> args proof-chunks)} (join [new-goal-record-1 new-goal-record-2] rest) } + | [goal [(negative-existential-sentence as (forall (some-var v) (some-sentence body)))]] => + let {_ := (mark `1)} + match (Polarities.find-universally-negative-occurrence* negative-existential-sentence (join (ab) (goal-record 'assumptions))) { + () => (error "Incorrect application of 'exists->: The given universal quantification is not negatively embedded in the current set of assumptions.") + | (some-map D) => + let {subgoal := (not negative-existential-sentence); + _ := (mark `2); + witness-var := (fresh-var (sort-of v) 'witness); + witness-marker := (marker); + pat-replacement-pairs := [[(val->string witness-var) "w"]]; + cm := (join "**" (val->string (current-marker-counter))); + _ := (HashTable.add marker-replacements [cm pat-replacement-pairs]); + _ := (print "\nCurrent marker counter: " cm); + _ := (print "\n pat-replacement-pairs:\n" pat-replacement-pairs); + witness-body := (replace-var v witness-var (not body)); + _ := (print "\nWITNESS BODY:\n" witness-body); + new-goal-record-1 := (make-child goal-record [['goal subgoal]]); + new-goal-record-2 := (make-child goal-record [['assumptions (add-all witness-body (goal-record 'assumptions))] + ['witnesses (add witness-var (goal-record 'witnesses))]]); + proof-chunks := (join ["let {negative-universal := " witness-marker ";\n existential := (!qn-strict negative-universal)" "}\n "] + ["pick-witness w for existential"] + ["\n "] + [(marker)]); + _ := (set-proof-and-tactic-info goal-record 'exists-> args proof-chunks)} + (join [new-goal-record-1 new-goal-record-2] rest) + } | _ => (error "The exists-> tactic expects an existential quantification as its sole argument, or else no arguments at all.") } | _ => (error "Invalid tactic application - there are no open goals currently.") @@ -690,11 +726,28 @@ EOF load "lib/basic/tactics" assert p1 := (forall x . P x ==> Q x) -assert p2 := (exists x . P x) +assert p2 := (and true (exists x (P x))) +(set-goal (exists x . Q x)) +(apply-tactic 'exists-> [(exists x (P x))]) + +(apply-tactic 'exists<- [[?witness1061:Int]]) +(apply-tactic* 'extract []) +(print (show-proof)) + + + +assert p1 := (forall x . P x ==> Q x) +assert p2 := (and true (not (forall x (not (P x))))) (set-goal (exists x . Q x)) -(apply-tactic 'exists-> [p2]) -(apply-tactic 'exists<- [[?witness964:Int]]) +(apply-tactic 'exists-> [(forall x (not (P x)))]) +(apply-tactic 'exists<- [[?witness1061:Int]]) (apply-tactic* 'extract []) +(print (show-proof)) + + +(apply-tactic 'extract []) +(apply-tactic 'extract []) +(apply-tactic 'extract []) (print (show-proof)) From 10e1c904c316e92ac812664b8b3d0d9bf58d830b Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Sun, 27 Oct 2024 12:29:43 -0400 Subject: [PATCH 39/49] Allowing for negative extractions, where the parent flips the goal's polarity but is itself negatively embedded in a premise --- lib/basic/polarities.ath | 22 ++++++++++++++++ lib/basic/tactics.ath | 56 ++++++++++++++++++++++++++++++---------- 2 files changed, 64 insertions(+), 14 deletions(-) diff --git a/lib/basic/polarities.ath b/lib/basic/polarities.ath index 8f45972..76be77f 100644 --- a/lib/basic/polarities.ath +++ b/lib/basic/polarities.ath @@ -48,6 +48,26 @@ define (flip pol) := (polarities p body))) (_ [])))) +define (get-polarity position base) := +# Find the polarity of a certain position (subsentence occurrence) inside a base sentence. +# If the given position is not valid in base, return (). Otherwise return 'p, 'n, or 'pn accordingly. + let {new-polarity := lambda (p i current-polarity) + match [p i] { + [(not _) 1] => (flip current-polarity) + | [(if _ _) 1] => (flip current-polarity) + | [(iff _ _) (|| 1 2)] => 'pn + | _ => current-polarity + }} + letrec {loop := lambda (position p polarity) + match [position p] { + [[] _] => polarity + | [(list-of i more) ((some-sent-con sc) (some-list props))] => (loop more (nth i props) (new-polarity p i polarity)) + | [(list-of 2 more) ((some-quant _) (some-var _) (some-sentence body))] => (loop more body polarity) + | _ => (print "Something went wrong, here's [position p]: " [position p]) + }} + try {(loop position base 'p) | () } + + define (extend-map M k v) := let {res := try { (M k) | [] }} (Map.add M [[k (add v res)]]) @@ -345,6 +365,8 @@ define (ufv p subsentence-position) := (list-diff q-fvars p-fvars) define (find-universally-positive-parent goal premise) := +# This actually finds a universally positive occurrence of the goal. The returned parent itself +# might or might not be in a positive position. let {compromise-result := (cell ()); update-theta := lambda (D) let {parent-ufvs := (ufv premise (D 'match-parent-position)); diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 4addc0b..67fe2b2 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -255,7 +255,9 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise # where is a meta-identifier representing a proper (fully specified) extraction # tactic name, and args is the list of all those values that are necessary for the tactic to work. let {aux-info := |{'premise := premise, 'goal-parent := parent, 'parent-position-in-premise := parent-position-in-premise, 'theta := theta}|; - _ := (print "\nHERE'S THETA: " theta); + parent-polarity-in-premise := (Polarities.get-polarity parent-position-in-premise premise); + negative-parent-polarity := (Polarities.negative-pol? parent-polarity-in-premise); + non-negative-parent-polarity := (negate negative-parent-polarity); instantiated-parent := (theta parent)} match instantiated-parent { @@ -311,26 +313,31 @@ define (proper-extraction-tactic goal premise parent parent-position-in-premise 'proof := ["let {cond := " (marker) ";\n ant := " (marker) "\n }\n (!mp cond ant)"], 'subgoals := [instantiated-parent antecedent]}| - | (iff left (val-of goal)) => + | ((iff left (val-of goal)) where non-negative-parent-polarity) => |{'tactic-info := ['iff-left-> aux-info], 'proof := ["let {bicond := " (marker) ";\n left := " (marker) "\n }\n (!mp (!left-iff bicond) left)"], 'subgoals := [instantiated-parent left]}| - | (iff (val-of goal) right) => + | ((iff (val-of goal) right) where non-negative-parent-polarity) => |{'tactic-info := ['iff-right-> aux-info], 'proof := ["let {bicond := " (marker) ";\n right := " (marker) "\n }\n (!mp (!right-iff bicond) right)"], 'subgoals := [instantiated-parent right]}| - | (not (some-sentence body)) => - # If the parent is the negation of the goal, but the parent itself is negated, then - let {grand-parent := (Polarities.subprop premise (all-but-last parent-position-in-premise))} - check {(&& (non-empty? parent-position-in-premise) - (equals? (root grand-parent) not)) => - |{'tactic-info := ['not-> aux-info], - 'subgoals := [grand-parent], - 'proof := ["let {doubly-negated-goal := " (marker) "}\n (!dn doubly-negated-goal)"]}| - | else => (error "Invalid application of not->")} - + | ((|| (not (some-sentence body)) + (if (val-of goal) (some-sentence consequent))) + where negative-parent-polarity) => + # In each of the 2 cases here, there will only be one subgoal: the negation of the parent (note: we know that + # the parent has negative polarity in the given premise, so (~ parent) should be derivable). So in each + # case, (marker) will be the proof of (not parent). + # The main goal will then need to be extracted from (~ parent) according to each case: where the parent + # is a negation, (not goal), or conditional of the form (if goal _). + let {proof := match instantiated-parent { + (not _) => ["let {doubly-negated-goal := " (marker) "}\n (!dn doubly-negated-goal)"] + | (if _ _) => ["let {negative-conditional := " (marker) "}\n (!left-and (!neg-cond negative-conditional))"] + }} + |{'tactic-info := ['neg-extract aux-info], + 'subgoals := [(not instantiated-parent)], + 'proof := proof}| | (forall (some-var v) (some-sentence _)) => |{'tactic-info := ['forall3-> aux-info], 'subgoals := let {_ := (print "\nINSTANTIATED PARENT: " instantiated-parent "\nAND PARENT: " parent)} @@ -477,7 +484,6 @@ define pick-witness-tactic := (join [new-goal-record-1 new-goal-record-2] rest) } | [goal [(negative-existential-sentence as (forall (some-var v) (some-sentence body)))]] => - let {_ := (mark `1)} match (Polarities.find-universally-negative-occurrence* negative-existential-sentence (join (ab) (goal-record 'assumptions))) { () => (error "Incorrect application of 'exists->: The given universal quantification is not negatively embedded in the current set of assumptions.") | (some-map D) => @@ -725,6 +731,28 @@ open Tactics EOF load "lib/basic/tactics" + +assert p := (B | ~ (A ==> C)) +assert p1 := (B ==> A) +(set-goal A) +(apply-tactic 'case-analysis [p]) +(apply-tactic 'back []) +(apply-tactic 'infer [method () (!neg-cond (not (if A C)))]) +qqq + + +(apply-tactic 'extract []) + + + +# WTF: +assert p := (B | (~A ==> C)) +assert p1 := (B ==> A) +assert p2 := (C ==> A) +(set-goal A) +(apply-tactic 'extract [p]) + + assert p1 := (forall x . P x ==> Q x) assert p2 := (and true (exists x (P x))) (set-goal (exists x . Q x)) From 27a2b195d84927ce0156da2e0994e5d45413f373 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 28 Oct 2024 11:02:51 -0400 Subject: [PATCH 40/49] Implemented forall2 -> --- lib/basic/tactics.ath | 63 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 58 insertions(+), 5 deletions(-) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 67fe2b2..5fb302a 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -45,7 +45,13 @@ module Tactics { define fresh-goal-id := lambda () (join "g" (val->string (inc goal-id-counter))) define (add-all p assumptions) := - (join assumptions (dedup (add p (get-conjuncts-recursive p)))) + (join (dedup (add p (get-conjuncts-recursive p))) assumptions) + + define (add-all* props assumptions) := + match props { + [] => assumptions + | (list-of p more) => (add-all* more (add-all p assumptions)) + } define clear-state := lambda () @@ -514,9 +520,48 @@ define pick-witness-tactic := } define (execute-thunk M assumptions) := - let {p := assume (and assumptions) (!M)} + let {sole-assumption := check {(null? assumptions) => true | _ => (and assumptions)}; + p := assume sole-assumption (!M)} (consequent p) +define (double-negation? p) := + match p { + (not (not _)) => true | _ => false + } + +define forall2->tactic := + lambda (goal-stack args) + # We must return a new goal stack. + match goal-stack { + (list-of goal-record rest) => + match args { + [(negative-existential-sentence as (exists (some-var v) (some-sentence body))) (some-term t)] => + match (Polarities.find-universally-negative-occurrence* negative-existential-sentence (join (ab) (goal-record 'assumptions))) { + () => (error "Incorrect application of 'forall2->: The given existential quantification is not negatively embedded in the current set of assumptions.") + | (some-map D) => + let {subgoal := (not negative-existential-sentence); + universal := (forall v (not body)); + new-goal-record-1 := (make-child goal-record [['goal subgoal]]); + new-conclusion-1 := (replace-var v t (not body)); + doubly-negated-body? := (double-negation? new-conclusion-1); + new-conclusions := check {doubly-negated-body? => [universal new-conclusion-1 (negation-body (negation-body new-conclusion-1))] | else => [universal new-conclusion-1]}; + new-goal-record-2 := (make-child goal-record [['assumptions (add-all* new-conclusions (goal-record 'assumptions))]]); + conditional-chunk := check {doubly-negated-body? => [";\n _ := (!dn instantiated-universal)}\n "] | else => ["}\n "]}; + proof-chunks := (join ["let {negative-existential := " (marker) ";\n "] + ["universal := (!qn-strict negative-existential) ;\n "] + ["instantiated-universal := (!uspec universal " (val->string t) ")"] + conditional-chunk + [(marker)]); + _ := (set-proof-and-tactic-info goal-record 'forall2-> args proof-chunks)} + (join [new-goal-record-1 new-goal-record-2] rest) + | _ => (print "Invalid result obtained from Polarities.find-universally-negative-occurrence* - a dictionary was expected here.") + } + | _ => (error "Invalid tactic application: forall2-> expects 2 arguments, a negatively embeed existential quantification and a term.") + } + | _ => (error "Invalid tactic application - there are no open goals currently.") + } + + define infer-tactic := lambda (goal-stack args) # We must return a new goal stack. @@ -576,6 +621,7 @@ define tactic-dictionary := 'forall<- := lambda (goal-stack args) (backward-tactic goal-stack 'forall<- args), 'exists<- := lambda (goal-stack args) (backward-tactic goal-stack 'exists<- args), 'exists-> := pick-witness-tactic, + 'forall2-> := forall2->tactic, 'extract := extraction-tactic, 'infer := infer-tactic, 'contradiction := contradiction-tactic, @@ -731,6 +777,14 @@ open Tactics EOF load "lib/basic/tactics" +assert p1 := (forall x . P x ==> Q x) +assert p2 := (and true (not (exists x (not (P x))))) +(set-goal (exists x . Q x)) +(apply-tactic 'forall2-> [(exists x (not (P x))) a]) +(apply-tactic 'exists<- [[a]]) +(apply-tactic* 'extract []) +(apply-tactic 'extract []) + assert p := (B | ~ (A ==> C)) assert p1 := (B ==> A) @@ -738,8 +792,6 @@ assert p1 := (B ==> A) (apply-tactic 'case-analysis [p]) (apply-tactic 'back []) (apply-tactic 'infer [method () (!neg-cond (not (if A C)))]) -qqq - (apply-tactic 'extract []) @@ -780,8 +832,9 @@ assert p2 := (and true (not (forall x (not (P x))))) (print (show-proof)) - +qqq (apply-tactic 'infer [method () (!uspec p1 ?witness964:Int)]) +(apply-tactic 'infer [method () (!uspec p1 ?foo)]) assert p1 := (forall x . P x | Q x) From a05d1610bd2c3923d97c46ba58e5421ad5c35016 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 28 Oct 2024 14:43:21 -0400 Subject: [PATCH 41/49] Implemented replace< --- lib/basic/tactics.ath | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/lib/basic/tactics.ath b/lib/basic/tactics.ath index 5fb302a..c6ee08d 100644 --- a/lib/basic/tactics.ath +++ b/lib/basic/tactics.ath @@ -582,6 +582,35 @@ define infer-tactic := | _ => (error "Invalid tactic application - there are no open goals currently.") } +define (get-method-name M) := + let {long-name := (val->string M)} + match (skip-until' long-name white-space-character?) { + [first-chunk _] => first-chunk + | _ => long-name + } + + +define replacement-tactic<- := + lambda (goal-stack args) + # We must return a new goal stack. + match goal-stack { + (list-of goal-record rest) => + match args { + [(some-sentence goal') ((some-list methods) where (for-each methods method?))] => + let {_ := (print "\nINSIDE BACKWARD REPLACEMENT TACTIC"); + goal := (goal-record 'goal); + new-goal := (make-child goal-record [['goal goal']]); + _ := (set! (goal-record 'tactic) ['replace<- args]); + method-names-str := (separate (map get-method-name methods) " "); + proof-chunks := ["let {_ := " (marker) "\n }\n " "(!transform " (val->string goal') " " (val->string goal) " [" method-names-str "])\n "]; + _ := (set-proof-and-tactic-info goal-record 'replace<- args proof-chunks) + } + (add new-goal rest) + | _ => (print "Invalid application of replace<- tactic, which expects two arguments: a transformed goal and a list of methods.") + } + | _ => (error "Invalid tactic application - there are no open goals currently.") + } + define (go-back-to goal-stack target-path) := let {new-stack := (filter-out goal-stack lambda (goal-record) @@ -624,6 +653,7 @@ define tactic-dictionary := 'forall2-> := forall2->tactic, 'extract := extraction-tactic, 'infer := infer-tactic, + 'replace<- := replacement-tactic<-, 'contradiction := contradiction-tactic, 'case-analysis := case-analysis-tactic, 'from-complements := from-complements-tactic, @@ -777,6 +807,15 @@ open Tactics EOF load "lib/basic/tactics" + + + +assert p1 := (forall x . P x ==> Q x) +assert p2 := (exists x . P x) +(set-goal (exists x . ~ ~ Q x)) +(apply-tactic 'replace<- [(exists x . Q x) [bdn]]) + + assert p1 := (forall x . P x ==> Q x) assert p2 := (and true (not (exists x (not (P x))))) (set-goal (exists x . Q x)) From 2e8f75d095433a057d4feb3f8207aeda9f2eb388 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Mon, 4 Nov 2024 18:20:11 -0500 Subject: [PATCH 42/49] Reimplementing simplification so that it works directly on Athena proof ASTs --- abstract_syntax.sml | 20 ++++++++++- athena.mlb | 1 - lib/basic/list.ath | 2 ++ prop.sig | 8 +++-- prop.sml | 76 ++++++++++++++++++++++++++++++++--------- simp.sml | 83 +++++++++++++++++++++++++++++++++++++++++++++ sources.cm | 1 + topenv_part1.sml | 5 ++- 8 files changed, 173 insertions(+), 23 deletions(-) create mode 100644 simp.sml diff --git a/abstract_syntax.sml b/abstract_syntax.sml index 39ddb34..bfcaa1d 100755 --- a/abstract_syntax.sml +++ b/abstract_syntax.sml @@ -1011,7 +1011,25 @@ and unparseDed(methodAppDed({method,args,pos})) = "(!"^(unparseExp method)^space | unparseDed(UMethAppDed({method, arg, pos})) = "(!"^(unparseExp method)^space^(Basic.printSExpListStr([arg],unparsePhrase))^")" | unparseDed(BMethAppDed({method, arg1, arg2, pos})) = "(!"^(unparseExp method)^space^(Basic.printSExpListStr([arg1,arg2],unparsePhrase))^")" | unparseDed(letDed({bindings,body,pos,...})) = "let {"^(unparseBindingsInfix bindings)^"}"^space^(unparseDed body) - | unparseDed(_) = "(Don't know how to unparse this deduction yet.)" + | unparseDed(beginDed({members,pos,...})) = "{"^(Basic.printListStr(members, unparseDed, ";\n"))^"}" + | unparseDed(matchDed(_)) = "Match ded!" + | unparseDed(letRecDed(_)) = "Letrec ded!" + | unparseDed(checkDed(_)) = "Check ded!" + | unparseDed(assumeDed(_)) = "Assume ded!" + | unparseDed(infixAssumeDed(_)) = "Infix Assume ded!" + | unparseDed(assumeLetDed(_)) = "Assume-Let ded!" + | unparseDed(absurdDed(_)) = "Absurd ded!" + | unparseDed(tryDed(_)) = "Try ded!" + | unparseDed(absurdLetDed(_)) = "Absurd-Let ded!" + | unparseDed(inductionDed(_)) = "Induction ded!" + | unparseDed(structureCasesDed(_)) = "Structure-Cases ded!" + | unparseDed(byDed(_)) = "By ded!" + | unparseDed(fromDed(_)) = "From ded!" + | unparseDed(genOverDed(_)) = "Gen-over ded!" + | unparseDed(pickAnyDed(_)) = "Pick-any ded!" + | unparseDed(withWitnessDed(_)) = "With-witness ded!" + | unparseDed(pickWitnessDed(_)) = "Pick-witness ded!" + | unparseDed(pickWitnessesDed(_)) = "Pick-witnesses ded!" and unparsePhrase(exp(e)) = unparseExp(e) | unparsePhrase(ded(d)) = unparseDed(d) and diff --git a/athena.mlb b/athena.mlb index 6970b8b..37d9b63 100755 --- a/athena.mlb +++ b/athena.mlb @@ -92,6 +92,5 @@ in repl.sml athena.sml sml_c_util.sml - mlton_main_old.sml mlton_main.sml end diff --git a/lib/basic/list.ath b/lib/basic/list.ath index aff7201..7f337cb 100644 --- a/lib/basic/list.ath +++ b/lib/basic/list.ath @@ -132,6 +132,8 @@ (define (list-remove x L) (remove x L)) +define (list-remove* to-be-removed L) := (list-diff L to-be-removed) + (define (remove-and-preserve-order a L) (letrec ((loop (lambda (rest already-seen) (match rest diff --git a/prop.sig b/prop.sig index 378f477..7f9ac21 100755 --- a/prop.sig +++ b/prop.sig @@ -181,9 +181,13 @@ sig val makePolyPropList: prop list * string * (string -> string) -> (string * string list * ModSymbol.mod_symbol list) * (string * string list) * string list * ModSymbol.mod_symbol list (* satSolveTableau is a simple tableau-based propositional sat solver. If the input sentences are satisfiable, the result - is SOME(L) where L is list of literals representing a satisfying interpretation; otherwise NONE is returned. *) - + is SOME(L) where L is list of literals representing a satisfying interpretation; otherwise NONE is returned. + val satSolveTableau: prop list -> prop list option +*) + + val satSolveTableauNew: prop list -> bool + (* satSolvableTableau uses a similar technique but only returns a yes/no answer. *) val satSolvableTableau: prop list -> bool option diff --git a/prop.sml b/prop.sml index 890bf00..d432bef 100755 --- a/prop.sml +++ b/prop.sml @@ -1629,10 +1629,16 @@ fun isMember(atom({term=t,...}),lits) = SOME(_) => true | _ => false)) -fun insert(l as atom({term=t,...}),lits) = if isMember(l, lits) then lits else +fun insert(l as atom({term=t,...}),lits) = + let + val res = if isMember(l, lits) then lits else (case AT.isVarOpt(t) of SOME(v) => ATV.enter(lits,v,true)) + in + res + end + fun pNegOfq(p,q) = (case p of neg({arg,...}) => alEq(arg,q) @@ -1648,16 +1654,21 @@ fun literal(atom(_)) = true fun sat(props,plits,nlits) = let val counter = ref 0 + fun getPosLits(lits) = let fun makeProp(v,_) = atom({term=AT.makeVar(v),hash_code=ATV.hash(v),flags=(ref NONE,zero_word)}) + in + map makeProp (ATV.listAll lits) + end + fun getNegLits(lits) = let fun makeProp(v,_) = makeNegation(atom({term=AT.makeVar(v),hash_code=ATV.hash(v),flags=(ref NONE,zero_word)})) + in + map makeProp (ATV.listAll lits) + end fun loop(props,plits,nlits) = let val _ = counter := !counter + 1 - fun getPosLits(lits) = let fun makeProp(v,_) = atom({term=AT.makeVar(v),hash_code=ATV.hash(v),flags=(ref NONE,zero_word)}) - in - map makeProp (ATV.listAll lits) - end - fun getNegLits(lits) = let fun makeProp(v,_) = makeNegation(atom({term=AT.makeVar(v),hash_code=ATV.hash(v),flags=(ref NONE,zero_word)})) - in - map makeProp (ATV.listAll lits) - end +(****) + val _ = print("\nIterating on these props: " ^ (Basic.printListStr(props,toString1,"\n")) + ^ "\nthese plits: " ^ (Basic.printListStr(getPosLits(plits),toString1,"\n")) + ^ "\nand these nlits:\n" ^ (Basic.printListStr(getNegLits(nlits),toString1,"\n"))) +(****) in (case props of conj({args=[p1,p2],...})::rest => if literal(p2) then loop(p2::p1::rest,plits,nlits) else loop(p1::p2::rest,plits,nlits) @@ -1677,7 +1688,7 @@ fun sat(props,plits,nlits) = loop(neg({arg=p1,flags=flags,fvars=fvars,hash_code=hash_code,poly_constants=poly_constants}):: neg({arg=p2,flags=flags,hash_code=hash_code,fvars=fvars,poly_constants=poly_constants}):: rest,plits,nlits) - else loop(neg({arg=p2,flags=flags,hash_code=hash_code,fvars=fvars,poly_constants=poly_constants}):: + else loop(neg({arg=p2,flags=flags,hash_code=hash_code,fvars=fvars,poly_constants=poly_constants}):: neg({arg=p1,hash_code=hash_code,flags=flags,fvars=fvars,poly_constants=poly_constants}):: rest,plits,nlits) | neg({arg=cond({ant,con,hash_code,flags,fvars,poly_constants,...}),...})::rest => @@ -1688,7 +1699,10 @@ fun sat(props,plits,nlits) = | neg({arg=neg({arg=p,...}),...})::rest => loop(p::rest,plits,nlits) | (l as (neg({arg=l',...})))::rest => if isMember(l',plits) then false else loop(rest,plits,(insert(l',nlits))) - | l::rest => if isMember(l,nlits) then false else loop(rest,insert(l,plits),nlits) + | l::rest => let + in + if isMember(l,nlits) then false else loop(rest,insert(l,plits),nlits) + end | _ => true) end in @@ -1702,7 +1716,8 @@ fun satSolvableTableau(props) = if res then SOME(res) else NONE end -(* Slightly different redefinition of tableu satisfiability for the solver: *) +(***** + Slightly different redefinition of tableu satisfiability for the solver: fun sat((conj({args=[p1,p2],...}))::rest,plits,nlits) = sat(p1::p2::rest,plits,nlits) | sat((disj({args=[p1,p2],...}))::rest,plits,nlits) = sat(p1::rest,plits,nlits) orelse sat(p2::rest,plits,nlits) @@ -1735,6 +1750,16 @@ fun satSolveTableau(props) = if res then SOME(!cell) else NONE end +****) + +fun satSolveTableauNew(props) = + let val cell = ref [] + val res = sat(props,ATV.empty_mapping,ATV.empty_mapping) + in + res + end + + fun isSortInstance(P1,P2) = let val (word1,word2) = (getWord P1,getWord P2) fun sortsMatch(sorts1,sorts2) = @@ -4085,9 +4110,10 @@ let val A = Unsafe.Array.create(10+array_n,false) " ") ^ " 0\n" val clause_strings = map clauseToString clauses val dimacs_stream = TextIO.openOut(dimacs_file_name) - val _ = TextIO.output(dimacs_stream,"p cnf "^(Int.toString(!total_var_count))^" "^(Int.toString(clause_num))^"\n") - val _ = List.app (fn cl => TextIO.output(dimacs_stream,cl)) clause_strings - + val _ = ((TextIO.output(dimacs_stream,"p cnf "^(Int.toString(!total_var_count))^" "^(Int.toString(clause_num))^"\n"); + List.app (fn cl => TextIO.output(dimacs_stream,cl)) clause_strings) + handle exn => (TextIO.closeOut dimacs_stream; raise exn) + before TextIO.closeOut dimacs_stream) in TextIO.closeOut(dimacs_stream) end @@ -4095,19 +4121,35 @@ end fun runSatSolver(dimacs_file,out_file_name) = let val (error_file,other_file) = ("minisat_error2.txt", "other_out_mini2.txt") val sat_solver_cmd = Names.minisat_binary ^ " -verb=0 "^dimacs_file^" "^out_file_name^" 1> "^other_file^" 2> "^error_file + +(*** val _ = OS.Process.system(sat_solver_cmd) +***) + val result = OS.Process.system(sat_solver_cmd) +(*** + val _ = if result = 10 orelse result = 20 + then () + else Basic.fail("SAT solver did not complete successfully") +***) +(*** val _ = (List.app OS.FileSys.remove [error_file,other_file]) handle _ => () +***) + (* Remove temporary files with a structured exception handler *) + val _ = (List.app (fn file => (OS.FileSys.remove file handle _ => ())) + [error_file, other_file]) in () end +val dimacs_counter = ref(0) + fun propSat(props, out_hash_table, transformProp, transformBool) = let val r as {clauses,table=inverse_atom_table,total_var_num,tseitin_var_num,clause_num,cnf_conversion_time,array_n,...} = cnfLst(props) - val (dimacs_file,minisat_out_file_name) = ("dimacs_file.txt","./minisat_out.txt") + val (dimacs_file,minisat_out_file_name) = ("dimacs_file_" ^ (Int.toString (Basic.incAndReturn(dimacs_counter))) ^ ".txt" ,"./minisat_out.txt") val t1 = Time.toReal(Time.now()) val _ = makeDimacsFile(r,dimacs_file) val t2 = Time.toReal(Time.now()) @@ -4117,6 +4159,8 @@ fun propSat(props, val sat_solving_time = (Real.-(t3,t2)) val out_stream = TextIO.openIn(minisat_out_file_name) val res = getMiniSatResult(out_stream,inverse_atom_table,out_hash_table,transformProp,transformBool) + val _ = List.app (fn file => (OS.FileSys.remove file handle _ => ())) + [dimacs_file,minisat_out_file_name] in {assignment=res, clause_num=clause_num, diff --git a/simp.sml b/simp.sml new file mode 100644 index 0000000..2af3524 --- /dev/null +++ b/simp.sml @@ -0,0 +1,83 @@ +structure Simplify_New = + +struct + +exception IllFormedProof + +structure A = AbstractSyntax; + +fun illFormed() = raise IllFormedProof; + +fun fp f = fn D => let val D' = f D + in + if D = D' then D else (fp f) D' + end; + +fun weave f [] = f + | weave f (g::rest) = f o g o (weave f rest); + +fun memberOf L x = List.exists (fn a => a = x) L; + +fun emptyIntersection(L1,L2) = not (List.exists (memberOf L2) L1); + +fun remove(x,L) = List.filter (fn y => not(x = y)) L; + +fun removeDuplicates [] = [] + | removeDuplicates (x::rest) = x::removeDuplicates(remove(x,rest)); + +fun getThreadElements(A.beginDed({members,...})) = Basic.flatten(map getThreadElements members) + | getThreadElements(D) = [D]; + + + + +fun getPropsAndEnv([],props,env,_) = (props,env) + | getPropsAndEnv((b:A.binding as {bpat,pos,def,...})::rest,props,env,ab) = + let val pval = Semantics.evalPhrase(def,env,ab) + in + (case Semantics.coerceValIntoProp(pval) of + SOME(p) => (case Semantics.matchPat(pval,bpat,makeEvalExpFunction (env,ab)) of + SOME(map,_) => let val (vmap,mmap) = Semantics.getValAndModMaps(!env) + val env' = ref(Semantics.valEnv({val_map=Symbol.augment(vmap,map),mod_map=mmap})) + in + getPropsAndEnv(rest,p::props,env',ab) + end + | _ => Basic.fail("Assume pattern failed to match the corresponding value.")) + | _ => Basic.fail("A sentence (hypothesis) was expected here...")) + end +and makeEvalExpFunction(env,ab) = + (fn (e,binding_map) => (case binding_map of + NONE => Semantics.evalExp(e,env,ab) + | SOME(map) => Semantics.evalExp(e,ref(Semantics.augmentWithMap(!env,map)),ab))) + + +fun conclusion(D,starting_env:SemanticValues.value_environment ref,starting_ab) = + let fun C(A.assumeDed({assumption,body,...}),env) = + let val p = C(body,env) + in + (case Semantics.evalPhrase(assumption,env,starting_ab) of + Semantics.propVal(hyp) => Prop.makeConditional(hyp,p) + | _ => Basic.fail("A sentence was expected here.")) + end + | C(A.beginDed({members,...}),env) = C(List.last members,env) + | C(A.absurdDed({hyp,body,...}),env) = + (case Semantics.evalPhrase(hyp,env,starting_ab) of + Semantics.propVal(hyp) => Prop.makeNegation(hyp) + | _ => Basic.fail("A sentence was expected here.")) + | C(A.infixAssumeDed({bindings,body,...}),env) = + let val (props,new_env) = getPropsAndEnv(bindings,[],env,starting_ab) + val hyps = rev(props) + val q = C(body,env) + in + (case hyps of + [P] => Prop.makeConditional(P,q) + | _ => Prop.makeConditional(Prop.makeConjunction(hyps),q)) + end + | C(_) = Basic.fail("Unable to compute conclusions for this type of deduction.") + + in + C(D,starting_env) + end + + +end; (* of structure Simplify_New *) diff --git a/sources.cm b/sources.cm index 0a55f0f..45cce0b 100755 --- a/sources.cm +++ b/sources.cm @@ -87,6 +87,7 @@ Group is server.sml topenv_part1.sml topenv_part2.sml + simp.sml definition_processor.sml repl.sml athena.sml diff --git a/topenv_part1.sml b/topenv_part1.sml index 009ed48..b1defaf 100755 --- a/topenv_part1.sml +++ b/topenv_part1.sml @@ -2375,12 +2375,11 @@ fun freeVarsPrimUFun(listVal(pvals),env,_) = fun satSolve([listVal pvals],env,_) = let val props = Semantics.getProps(pvals,"the argument list given to "^"ssat",env) in - case Prop.satSolveTableau(props) of - SOME(props) => listVal(map propVal props) - | _ => MLBoolToAth(false) + MLBoolToAth(Prop.satSolveTableauNew(props)) end | satSolve(_) = primError("Incorrect invocation of ssat") + fun satSolve0([listVal pvals],env,_) = let val props = Semantics.getProps(pvals,"the argument list given to "^"ssat",env) in From 633ea25c783ee73081d4f4ed336ebea34bcdee11 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Tue, 5 Nov 2024 19:34:04 -0500 Subject: [PATCH 43/49] WIP --- abstract_syntax.sml | 12 +- lib/basic/rewriting.ath | 7 - lib/basic/smt.ath | 520 ---------------------------------------- repl.sml | 8 +- simp.sml | 137 ++++++++++- topenv_part1.sml | 24 ++ topenv_part2.sml | 16 -- 7 files changed, 170 insertions(+), 554 deletions(-) diff --git a/abstract_syntax.sml b/abstract_syntax.sml index bfcaa1d..d90d110 100755 --- a/abstract_syntax.sml +++ b/abstract_syntax.sml @@ -1007,8 +1007,16 @@ and unparseBinding({bpat,def,...}) = lparen^(printPat bpat)^space^(unparsePhrase and unparseBindingInfix({bpat,def,...}) = (printPat bpat)^ " := " ^(unparsePhrase def) and unparseBindings(bindings) = Basic.printSExpListStr(bindings,unparseBinding) and unparseBindingsInfix(bindings) = Basic.printListStr(bindings,unparseBindingInfix,"; ") -and unparseDed(methodAppDed({method,args,pos})) = "(!"^(unparseExp method)^space^(Basic.printSExpListStr(args,unparsePhrase))^")" - | unparseDed(UMethAppDed({method, arg, pos})) = "(!"^(unparseExp method)^space^(Basic.printSExpListStr([arg],unparsePhrase))^")" +and unparseDed(methodAppDed({method,args,pos})) = + let + in + "(!"^(unparseExp method)^space^(Basic.printSExpListStr(args,unparsePhrase))^")" + end + | unparseDed(UMethAppDed({method, arg, pos})) = + let + in + "(!"^(unparseExp method)^space^(Basic.printSExpListStr([arg],unparsePhrase))^")" + end | unparseDed(BMethAppDed({method, arg1, arg2, pos})) = "(!"^(unparseExp method)^space^(Basic.printSExpListStr([arg1,arg2],unparsePhrase))^")" | unparseDed(letDed({bindings,body,pos,...})) = "let {"^(unparseBindingsInfix bindings)^"}"^space^(unparseDed body) | unparseDed(beginDed({members,pos,...})) = "{"^(Basic.printListStr(members, unparseDed, ";\n"))^"}" diff --git a/lib/basic/rewriting.ath b/lib/basic/rewriting.ath index a2bc92b..b0af9f6 100644 --- a/lib/basic/rewriting.ath +++ b/lib/basic/rewriting.ath @@ -4657,13 +4657,6 @@ set-precedence holds? 2 (max-cost (sum (length vars)))) [constraint vars cost-constraint cost-term max-cost])) -(define [constraint-30 vars-30 cost-constraint-30 cost-term-30 max-cost-30] (make-constraint 30)) - -(define [constraint-100 vars-100 cost-constraint-100 cost-term-100 max-cost-100] (make-constraint 100)) - -# (running-time (lambda () (solve-and-minimize (and constraint-30 cost-constraint-30) cost-term-30 max-cost-30)) 0) - -# (solve-and-minimize (and constraint-100 cost-constraint-100) cost-term-100 max-cost-100) } diff --git a/lib/basic/smt.ath b/lib/basic/smt.ath index fd5e3bf..70e01c3 100644 --- a/lib/basic/smt.ath +++ b/lib/basic/smt.ath @@ -1217,523 +1217,3 @@ # (testtc 700) -> 1.90 EOF - -# (load-file "smt.ath") - -(domains D1 D2) - -(declare f1 (-> (D1) D1)) -(declare g2 (-> (D1 D2) D1)) - -(declare d1 D1) -(declare d2 D2) - -(datatype Day - Mon Tue Wed Thu Fri Sat Sun) - -(declare nextDay (-> (Day) Day)) - -(define nextDay-axioms - [(nextDay Mon = Tue) - (nextDay Tue = Wed) - (nextDay Wed = Thu) - (nextDay Thu = Fri) - (nextDay Fri = Sat) - (nextDay Sat = Sun) - (nextDay Sun = Mon)]) - -(datatype Color - red blue green) - -(datatype IntList - nil - (cons HEAD:Int IntList)) - -(datatype IntList2 - nil2 - (cons2 HEAD2:Int TAIL2:IntList2)) - -(define (test n x) (running-time (lambda () (test-max n)) x)) - -(define large-constraint - (let (([A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20] - [?A1:Int ?A2:Int ?A3:Int ?A4:Int ?A5:Int ?A6:Int ?A7:Int ?A8:Int ?A9:Int ?A10:Int - ?A11:Int ?A12:Int ?A13:Int ?A14:Int ?A15:Int ?A16:Int ?A17:Int ?A18:Int ?A19:Int ?A20:Int])) - (or (and (A1 in [10 20]) - (A2 in [30 40]) - (A3 in [40 50]) - (A4 in [50 60]) - (A5 in [60 70]) - (A6 in [70 80]) - (A7 in [80 90]) - (A8 in [90 100]) - (A9 in [100 110]) - (A10 in [110 120]) - (A11 in [120 130]) - (A12 in [130 140]) - (A13 in [140 150]) - (A14 in [150 160]) - (A15 in [160 170]) - (A16 in [170 180]) - (A17 in [180 190]) - (A18 in [190 200]) - (A19 in [200 210]) - (A20 in [210 220])) - (and (A1 in [210 220]) - (A2 in [230 240]) - (A3 in [240 250]) - (A4 in [250 260]) - (A5 in [260 270]) - (A6 in [270 280]) - (A7 in [280 290]) - (A8 in [290 2100]) - (A9 in [2100 2110]) - (A10 in [2110 2120]) - (A11 in [2120 2130]) - (A12 in [2130 2140]) - (A13 in [2140 2150]) - (A14 in [2150 2160]) - (A15 in [2160 2170]) - (A16 in [2170 2180]) - (A17 in [2180 2190]) - (A18 in [2190 2200]) - (A19 in [2200 2210]) - (A20 in [2210 2220]))))) - -(define cost-function - (and (ite (= ?A1:Int 13) (= ?costA1:Int 0) - (= ?costA1:Int 3)) - (ite (= ?A2:Int 35) (= ?costA2:Int 0) - (= ?costA2:Int 2)) - (ite (= ?A19:Int 2207) (= ?costA19:Int 0) - (= ?costA19:Int 6)))) - -(define cost-term (?costA1:Int + ?costA2:Int + ?costA19:Int)) - -(smt-solve-and-minimize (and large-constraint cost-function) - cost-term 11) - -(define [constraint-2 vars-2 cost-constraint-2 cost-term-2 max-cost-2] (make-constraint 2)) - -(smt-solve-and-minimize (and constraint-2 cost-constraint-2) cost-term-2 max-cost-2) - -(define [constraint-30 vars-30 cost-constraint-30 cost-term-30 max-cost-30] (make-constraint 30)) - -(smt-solve constraint-30) - -(running-time (lambda () (smt-solve-and-minimize (and constraint-30 cost-constraint-30) cost-term-30 max-cost-30)) 0) - -(define [constraint-50 vars-50 cost-constraint-50 cost-term-50 max-cost-50] (make-constraint 50)) - -(smt-solve constraint-50) - -(running-time (lambda () (smt-solve constraint-50)) 0) - -(running-time (lambda () (smt-solve-and-minimize (and constraint-50 cost-constraint-50) cost-term-50 max-cost-50)) 0) - -(smt-solve-and-minimize (and constraint-50 cost-constraint-50) cost-term-50 max-cost-50) - -(define [constraint-70 vars-70 cost-constraint-70 cost-term-70 max-cost-70] (make-constraint 70)) - -(running-time (lambda () (smt-solve-and-minimize (and constraint-70 cost-constraint-70) cost-term-70 max-cost-70)) 0) - -(define [constraint-100 vars-100 cost-constraint-100 cost-term-100 max-cost-100] (make-constraint 100)) - -(running-time (lambda () (smt-solve constraint-100)) 0) - -(define [constraint-200 vars-200 cost-constraint-200 cost-term-200 max-cost-200] (make-constraint 200)) - -(smt-solve constraint-200) - -(define [constraint-300 vars-300 cost-constraint-300 cost-term-300 max-cost-300] (make-constraint 300)) - -(smt-solve constraint-300) - -(define [constraint-400 vars-400 cost-constraint-400 cost-term-400 max-cost-400] (make-constraint 400)) - -(smt-solve constraint-400) - -(define [constraint-500 vars-500 cost-constraint-500 cost-term-500 max-cost-500] (make-constraint 500)) - -(smt-solve constraint-500) - -(running-time (lambda () (smt-solve constraint-500)) 0) - -# MLton time -> 0.56 seconds -# SMLNJ time -> 1.14 seconds - -#============================================================================= - -(define large-max-constraint - [[large-constraint 'inf] - [(= ?A1:Int 13) 2] - [(= ?A2:Int 35) 3] - [(= ?A3:Int 45) 4] - [(= ?A4:Int 55) 5] - [(= ?A5:Int 55) 6] - [(= ?A6:Int 1999) 5] - [(= ?A7:Int 82) 7] - [(= ?A8:Int 93) 8] - [(= ?A9:Int 105) 9] - [(= ?A10:Int 114) 10] - [(= ?A11:Int 123) 11] - [(= ?A12:Int 133) 30] - [(= ?A13:Int 145) 12] - [(= ?A14:Int 155) 13] - [(= ?A15:Int 0) 13] - [(= ?A16:Int 88888) 13] - [(= ?A17:Int 88888) 20] - [(= ?A18:Int 192) 20] - [(= ?A19:Int 200) 20] - [(= ?A20:Int 200) 20]]) - -(max-smt-solve large-max-constraint) - -#============================================================================= - -(test-max 10) - -(test-max 20) - -(test-max 50) - -(test-max 70) - -(test-max 100) - -(test-max 140) - -(test-max 200) - -(test-max 300) - -#============================================================================= - -(define [min-diff-constraint total-diff] - (let (([A B C] [?A:Int ?B:Int ?C:Int]) - ([minDiffA minDiffB minDiffC] [?minDiffA:Int ?minDiffB:Int ?minDiffC:Int]) - (constraint (or (and (A in [10 20]) - (B in [1 20]) - (C in [720 800])) - (and (A in [500 600]) - (B in [30 40]) - (C in [920 925])))) - (minDiffA-def (ite (> A 13) (= minDiffA (- A 13)) - (= minDiffA (- 13 A)))) - (minDiffB-def (ite (> B 15) (= minDiffB (- B 15)) - (= minDiffB (- 15 B)))) - (minDiffC-def (ite (> C 922) (= minDiffC (- C 922)) - (= minDiffC (- 922 C))))) - [(and constraint minDiffA-def minDiffB-def minDiffC-def) - (sum-all [minDiffA minDiffB minDiffC])])) - -(max-smt-solve [[min-diff-constraint 'inf] - [(= ?A:Int 13) 10] - [(= ?B:Int 15) 20] - [(= ?C:Int 15) 25]]) - -(smt-solve-and-minimize min-diff-constraint total-diff 5000) - - -#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define large-constraint - (let (([A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20] - [?A1:Int ?A2:Int ?A3:Int ?A4:Int ?A5:Int ?A6:Int ?A7:Int ?A8:Int ?A9:Int ?A10:Int - ?A11:Int ?A12:Int ?A13:Int ?A14:Int ?A15:Int ?A16:Int ?A17:Int ?A18:Int ?A19:Int ?A20:Int])) - (or (and (A1 in [10 20]) - (A2 in [30 40]) - (A3 in [40 50]) - (A4 in [50 60]) - (A5 in [60 70]) - (A6 in [70 80]) - (A7 in [80 90]) - (A8 in [90 100]) - (A9 in [100 110]) - (A10 in [110 120]) - (A11 in [120 130]) - (A12 in [130 140]) - (A13 in [140 150]) - (A14 in [150 160]) - (A15 in [160 170]) - (A16 in [170 180]) - (A17 in [180 190]) - (A18 in [190 200]) - (A19 in [200 210]) - (A20 in [210 220])) - (and (A1 in [210 220]) - (A2 in [230 240]) - (A3 in [240 250]) - (A4 in [250 260]) - (A5 in [260 270]) - (A6 in [270 280]) - (A7 in [280 290]) - (A8 in [290 2100]) - (A9 in [2100 2110]) - (A10 in [2110 2120]) - (A11 in [2120 2130]) - (A12 in [2130 2140]) - (A13 in [2140 2150]) - (A14 in [2150 2160]) - (A15 in [2160 2170]) - (A16 in [2170 2180]) - (A17 in [2180 2190]) - (A18 in [2190 2200]) - (A19 in [2200 2210]) - (A20 in [2210 2220]))))) - -(define cost-function - (and (ite (= ?A1:Int 13) (= ?costA1:Int 0) - (= ?costA1:Int 3)) - (ite (= ?A2:Int 35) (= ?costA2:Int 0) - (= ?costA2:Int 2)) - (ite (= ?A19:Int 2207) (= ?costA19:Int 0) - (= ?costA19:Int 6)))) - -(define cost-term (?costA1:Int + ?costA2:Int + ?costA19:Int)) - -(smt-solve-and-minimize (and large-constraint cost-function) - cost-term 11) - -(smt-solve-and-minimize (and large-constraint cost-function) - cost-term 788000034) - -#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(define L [[(or (and (= ?x 2) (= ?y 3.4)) - (and (= ?x 5) (= ?d Mon))) 10] - [(or (and (= ?x 2) (= ?y 3.4)) - (and (= ?a 5) (= ?d Mon))) 20]]) - -(max-smt-solve L) - -(define L1 [[(or (and (= ?x 2) (= ?y 3.4)) - (and (= ?x 5) (= ?d Mon))) 10] - [(and (= ?x 99) (= ?y 99.9) (= ?a 9999) (= ?d Sun)) 20]]) - -(max-smt-solve L1) - -(define [constraint-2 vars-2 cost-constraint-2 cost-term-2 max-cost-2] (make-constraint 2)) - -(smt-solve-and-minimize (and constraint-2 cost-constraint-2) cost-term-2 max-cost-2) - -(define [constraint-5 vars-5 cost-constraint-5 cost-term-5 max-cost-5] (make-constraint 5)) - -(smt-solve-and-minimize (and constraint-5 cost-constraint-5) cost-term-5 max-cost-5) - -(define [constraint-20 vars-20 cost-constraint-20 cost-term-20 max-cost-20] (make-constraint 20)) - -(smt-solve-and-minimize (and constraint-20 cost-constraint-20) cost-term-20 max-cost-20) - -(define [constraint-30 vars-30 cost-constraint-30 cost-term-30 max-cost-30] (make-constraint 30)) - -(define (thunk-30) - (smt-solve-and-minimize (and constraint-30 cost-constraint-30) cost-term-30 max-cost-30)) - -(running-time thunk-30 0) - -(define [constraint-50 vars-50 cost-constraint-50 cost-term-50 max-cost-50] (make-constraint 50)) - -(define (thunk-50) - (smt-solve-and-minimize (and constraint-50 cost-constraint-50) cost-term-50 max-cost-50)) - -(smt-solve (and constraint-50 cost-constraint-50)) - -(running-time thunk-50 0) - -(define [constraint-60 vars-60 cost-constraint-60 cost-term-60 max-cost-60] (make-constraint 60)) - -(running-time (lambda () (smt-solve-and-minimize (and constraint-60 cost-constraint-60) cost-term-60 max-cost-60)) 0) - -(define [constraint-70 vars-70 cost-constraint-70 cost-term-70 max-cost-70] (make-constraint 70)) - -(define (thunk-70) - (smt-solve-and-minimize (and constraint-70 cost-constraint-70) cost-term-70 max-cost-70)) - -(running-time thunk-70 0) - -(define [constraint-90 vars-90 cost-constraint-90 cost-term-90 max-cost-90] (make-constraint 90)) - -(smt-solve constraint-90) - -(smt-solve (and constraint-90 cost-constraint-90)) - -(define [constraint-150 vars-150 cost-constraint-150 cost-term-150 max-cost-150] (make-constraint 150)) - -(smt-solve constraint-150) - -(smt-solve (and constraint-150 cost-constraint-150)) - -(define [constraint-200 vars-200 cost-constraint-200 cost-term-200 max-cost-200] (make-constraint 200)) - -(smt-solve constraint-200) - -(smt-solve (and constraint-200 cost-constraint-200)) - -(define [constraint-300 vars-300 cost-constraint-300 cost-term-300 max-cost-300] (make-constraint 300)) - -(smt-solve constraint-300) - -(smt-solve (and constraint-300 cost-constraint-300)) - -(define [constraint-500 vars-500 cost-constraint-500 cost-term-500 max-cost-500] (make-constraint 500)) - -(smt-solve constraint-500) - -##;;;;;;;;; - -(smt-solve (and constraint-30 cost-constraint-30)) - -(smt-solve (and constraint-30 cost-constraint-30 (0 <= cost-term-30) (cost-term-30 <= 232))) -(smt-solve (and constraint-30 cost-constraint-30 (232 <= cost-term-30) (cost-term-30 <= 465))) - -(smt-solve (and constraint-30 cost-constraint-30 (= ?TOTALCOST:Int cost-term-30) - (0 <= ?TOTALCOST:Int) - (?TOTALCOST:Int <= 465))) - - -(define [constraint-30 vars-30 cost-constraint-30 cost-term-30] (make-constraint 30)) - -(define [constraint30 vars] (make-constraint 30)) -(define [constraint40 vars] (make-constraint 40)) -(define [constraint50 vars] (make-constraint 50)) -(define [constraint100 vars] (make-constraint 100)) - - -#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -# Some simple generic examples: - - -(define c1 (or (and (= ?x 2) (= ?y 3.4)) - (and (= ?x 5) (= ?d Mon)))) - -(smt-solve c1) - -(define c2 (or (and (= ?x 2) (= ?y 3.4)) - (and (= ?a 5) (= ?d Mon)))) - -(smt-check c2 'Satisfiable) - -(define c3 (and (nextDay ?d = Thu) - (?x:Int =/= 2) - (?x:Int =/= 5) - (?color1 = red) - (conjoin nextDay-axioms))) - -(smt-solve c3) - -(smt-check c3 'Satisfiable) - -(define c4 (or (and (= ?x 2) (= ?y 3.4)) - (and (?c =/= blue) (?c =/= green)) - (and (= ?x 5) (= ?d Mon)))) - -(smt-solve c4) -(smt-check c4 'Satisfiable) - -(define c5 (and (?x:Int <= 2) - (?x:Int >= 0) - (or (= ?w Mon) - (not (= ?w Fri))))) - -(smt-solve c5) -(smt-check c5 'Satisfiable) - -(define c6 (or (and (= ?x 2) (= ?a 3)) - (and (= ?d Mon) (= Mon Tue)))) - - -(smt-solve c6) - -(smt-check c6 'Satisfiable) - -(define c7 (c6 & ~ c6)) - -(smt-solve c7) -(smt-check c7 'Unsatisfiable) - -(define c8 (and (f1 ?x = ?y) - (= ?y d1) - (forall ?foo . (not (= (f1 ?foo) d1))))) - - -(smt-solve c8) -(smt-check c8 'Unsatisfiable) - -(define (square x) (x * x)) - -(define c9 (= (3 * (square ?x:Real)) 12)) - -(smt-solve c9) -(smt-check c9 'Satisfiable) - -(define c10 (and ((square ?x:Int) = 25) - (?x:Int + ?y:Int = (2 * ?x:Int) - 1))) - -(smt-solve c10) -(smt-check c10 'Satisfiable) -(smt-check c10 'Unsatisfiable) - - -(define c11 - (?color =/= red & ?color =/= blue & ?color =/= green)) - -(smt-solve c11) - -(define c12 - (and (not (= ?l nil)) - (not (exists ?h (exists ?t (= ?l (cons ?h ?t))))))) - - -(smt-solve c12) - -(define c13 - (not (= (HEAD (cons ?x ?y)) ?x))) - -(smt-solve c13) - -(domain U) - -(declare F (-> (U) U)) -(declare foo U) - -(define c14 (and (= (F foo) foo) - (not (= (F ?x) ?x)))) - -(smt-solve c14) - - -(define c15 (and (= (F foo) foo) - (not (= (F ?x) ?x)) - (= (F ?y) ?x))) - -(smt-solve c15) - -(datatype IntList - null (cons Int IntList)) - - -(declare append (-> (IntList IntList) IntList)) - -(define ap-axiom-1 - (close (= (append null ?l) ?l))) - -(define ap-axiom-2 - (close (= (append (cons ?x ?l1) ?l2) - (cons ?x (append ?l1 ?l2))))) - -(define ap-axioms [ap-axiom-1 ap-axiom-2]) - -(assert ap-axioms) - -(define c1 (not (= (append ?c1 ?c2) (append ?c2 ?c1)))) - -(smt-solve (and* (add c1 ap-axioms))) - - - diff --git a/repl.sml b/repl.sml index 31f8788..bbc3140 100755 --- a/repl.sml +++ b/repl.sml @@ -799,8 +799,12 @@ fun getInputAndProcess() = end in if ok_input then - (List.app (fn i => processInputWithTopValBackUpRefreshed(i, [], ref(SV.valEnv({val_map=SV.empty_val_map,mod_map=SV.empty_mod_map})), - Semantics.top_val_env, N.top_level_name,top_loaded_files_ht)) + (List.app (fn i => processInputWithTopValBackUpRefreshed(i, + [], + ref(SV.valEnv({val_map=SV.empty_val_map,mod_map=SV.empty_mod_map})), + Semantics.top_val_env, + N.top_level_name, + top_loaded_files_ht)) user_inputs; TextIO.closeIn istream; ABase.adjustHashTable(!SM.top_assum_base); diff --git a/simp.sml b/simp.sml index 2af3524..b11c4d8 100644 --- a/simp.sml +++ b/simp.sml @@ -51,18 +51,114 @@ and makeEvalExpFunction(env,ab) = | SOME(map) => Semantics.evalExp(e,ref(Semantics.augmentWithMap(!env,map)),ab))) -fun conclusion(D,starting_env:SemanticValues.value_environment ref,starting_ab) = - let fun C(A.assumeDed({assumption,body,...}),env) = +fun getProp(phrase,env,ab) = + (case Semantics.coerceValIntoPropVal(Semantics.evalPhrase(phrase,env,ab)) of + SOME(Semantics.propVal(p)) => p + | _ => Basic.fail("A sentence was expected here.")) + +fun getLeftConjunct(p) = + (case Prop.isConj(p) of + SOME(l::_) => l + | _ => Basic.fail("A conjunction was expected here...")) + +fun getLeftIff(p) = + (case Prop.isBiCond(p) of + SOME(p1,p2) => Prop.makeConditional(p1,p2) + | _ => Basic.fail("A biconditional was expected here...")) + +fun getRightIff(p) = + (case Prop.isBiCond(p) of + SOME(p1,p2) => Prop.makeConditional(p2,p1) + | _ => Basic.fail("A biconditional was expected here...")) + +fun getRightConjunct(p) = + (case Prop.isConj(p) of + SOME(h::more) => Prop.makeConjunction(more) + | _ => Basic.fail("A conjunction was expected here...")) + +fun getDnBody(p) = + (case Prop.isNeg(p) of + SOME(q) => (case Prop.isNeg(q) of + SOME(r) => r + | _ => Basic.fail("A double negation was expected here...")) + | _ => Basic.fail("A double negation was expected here...")) + +fun getDmConclusion(p) = + (case Prop.isNeg(p) of + SOME(q) => (case Prop.isConj(q) of + SOME(props) => Prop.makeDisjunction(map Prop.makeNegation props) + | _ => (case Prop.isDisj(q) of + SOME(props) => Prop.makeConjunction(map Prop.makeNegation props) + | _ => Basic.fail("A conjunction or disjunction was expected here."))) + | _ => Basic.fail("A negation was expected here.")) + +fun getCondDefConclusion(p) = + (case Prop.isCond(p) of + SOME(q1,q2) => Prop.makeDisjunction([Prop.makeComplement(q1),q2]) + | _ => (case Prop.isDisj(p) of + SOME(d::more) => Prop.makeConditional(Prop.makeComplement(d),Prop.makeDisjunction(more)) + | _ => Basic.fail("A conditional or disjunction was expected here."))) + +fun getNegCondConclusion(p) = + (case Prop.isNeg(p) of + SOME(body) => + (case Prop.isCond(body) of + SOME(q1,q2) => Prop.makeConjunction([q1,Prop.makeNegation(q2)]) + | _ => Basic.fail("A conditional was expected here.")) + | _ => (case Prop.isConj(p) of + SOME([q1,q2]) => + (case Prop.isNeg(q2) of + SOME(body) => Prop.makeNegation(Prop.makeConditional(q1,q2)) + | _ => Basic.fail("A negation was expected here.")) + | _ => Basic.fail("A binary conjunction was expected here."))) + +fun getBdnConclusion(p) = + (case Prop.isNeg(p) of + SOME(q) => (case Prop.isNeg(q) of + SOME(r) => r + | _ => Prop.makeNegation(Prop.makeNegation(p))) + | _ => Prop.makeNegation(Prop.makeNegation(p))) + + +fun getCommConclusion(p) = Basic.fail("") + (case Prop.isConj(p) of + SOME(q1::more) => Prop.makeConjunction([Prop.makeDisjunction(more),q1]) + | _ => (case Prop.isDisj(p) of + SOME(q1::more) => Prop.makeDisjunction([Prop.makeDisjunction(more),q1]) + | _ => Basic.fail("A conjunction or disjunction was expected here."))) + +fun getContraPosConclusion(p) = + (case Prop.isCond(p) of + SOME(q1,q2) => + (case (Prop.isNeg(q1),Prop.isNeg(q2)) of + (SOME(q1'),SOME(q2')) => Prop.makeConditional(q2',q1') + | _ => Prop.makeConditional(Prop.makeNegation(q2),Prop.makeNegation(q1)))) + +fun getBiCondDefConclusion(p) = + (case Prop.isBiCond(p) of + SOME(q1,q2) => Prop.makeConjunction([Prop.makeConditional(q1,q2),Prop.makeConditional(q2,q1)]) + | _ => (case Prop.isConj(p) of + SOME([q1,q2]) => (case (Prop.isCond(q1),Prop.isCond(q2)) of + (SOME(p1,p2),SOME(p2',p1')) => Prop.makeBiConditional(p1,p2) + | _ => Basic.fail("")))) + +fun getNegatedBiCondDefConclusion(p) = Basic.fail("") + +fun getDistConclusion(p) = Basic.fail("") + +fun conclusion(D,starting_ab) = + let val _ = print("\nENTERING conclusion inside simp.sml...\n") + fun C(A.assumeDed({assumption,body,...}),env) = let val p = C(body,env) in - (case Semantics.evalPhrase(assumption,env,starting_ab) of - Semantics.propVal(hyp) => Prop.makeConditional(hyp,p) + (case Semantics.coerceValIntoProp(Semantics.evalPhrase(assumption,env,starting_ab)) of + SOME(hyp) => Prop.makeConditional(hyp,p) | _ => Basic.fail("A sentence was expected here.")) end | C(A.beginDed({members,...}),env) = C(List.last members,env) | C(A.absurdDed({hyp,body,...}),env) = - (case Semantics.evalPhrase(hyp,env,starting_ab) of - Semantics.propVal(hyp) => Prop.makeNegation(hyp) + (case Semantics.coerceValIntoPropVal(Semantics.evalPhrase(hyp,env,starting_ab)) of + SOME(Semantics.propVal(hyp)) => Prop.makeNegation(hyp) | _ => Basic.fail("A sentence was expected here.")) | C(A.infixAssumeDed({bindings,body,...}),env) = let val (props,new_env) = getPropsAndEnv(bindings,[],env,starting_ab) @@ -73,10 +169,37 @@ fun conclusion(D,starting_env:SemanticValues.value_environment ref,starting_ab) [P] => Prop.makeConditional(P,q) | _ => Prop.makeConditional(Prop.makeConjunction(hyps),q)) end + | C(A.UMethAppDed({method,arg,...}),env) = + let val p = getProp(arg,env,starting_ab) + in + (case method of + A.idExp({msym, mods=[],sym,...}) => + (case Symbol.name(sym) of + "claim" => p + | "force" => p + | "from-false" => p + | "bdn" => getBdnConclusion(p) + | "ex-middle" => Prop.makeDisjunction([p,Prop.makeNegation(p)]) + | "contra-pos" => getContraPosConclusion(p) + | "left-and" => getLeftConjunct(p) + | "right-and" => getRightConjunct(p) + | "left-iff" => getLeftIff(p) + | "right-iff" => getRightIff(p) + | "dn" => getDnBody(p) + | "dm" => getDmConclusion(p) + | "comm" => getCommConclusion(p) + | "dist" => getDistConclusion(p) + | "cond-def" => getCondDefConclusion(p) + | "neg-cond" => getNegCondConclusion(p) + | "bicond-def" => getBiCondDefConclusion(p) + | "negated-bicond" => getNegatedBiCondDefConclusion(p) + | _ => Basic.fail("Unknown unary method, cannot compute conclusion...")) + | _ => Basic.fail("Cannot compute conclusions for UMethodApps where the operator is not an identifier.")) + end | C(_) = Basic.fail("Unable to compute conclusions for this type of deduction.") in - C(D,starting_env) + C(D,SemanticValues.top_val_env) end diff --git a/topenv_part1.sml b/topenv_part1.sml index b1defaf..6500b99 100755 --- a/topenv_part1.sml +++ b/topenv_part1.sml @@ -716,6 +716,30 @@ fun unparseFun([closMethodVal(A.methodExp({params=[],body,pos,name}),env_ref)],e | unparseFun(vals,_,{pos_ar,file}) = evError(wrongArgNumber(N.unparseFun_name,length(vals),1),SOME(Array.sub(pos_ar,0))) +fun unparsePrimUFun(v,env,ab) = + (case v of + closUFunVal(e,_,_,{name,...}) => + MLStringToAthString("Unary procedure: " ^ (!name) ^ (A.unparseExp(e))) + | closBFunVal(e,_,_,_,{name,...}) => + MLStringToAthString("Binary procedure: " ^ (!name) ^ (A.unparseExp(e))) + | closFunVal(e,_,{name,...}) => + MLStringToAthString("Procedure: " ^ (!name) ^ (A.unparseExp(e))) + | closUMethodVal(d,_,_,name) => + let val conc = Simplify_New.conclusion(d,ab) + val _ = print("\nCONCLUSION:\n" ^ (Prop.toPrettyStringDefault(0,conc)) ^ "\n") + in + MLStringToAthString("Unary method: " ^ (!name) ^ (A.unparseDed(d))) + end + | closBMethodVal(d,_,_,_,name) => + MLStringToAthString("Binary method: " ^ (!name) ^ (A.unparseDed(d))) + | closMethodVal(e as A.methodExp({body,...}),_) => + let val conc = Simplify_New.conclusion(body,ab) + val _ = print("\nCONCLUSION:\n" ^ (Prop.toPrettyStringDefault(0,conc)) ^ "\n") + in + MLStringToAthString("Method: " ^ (A.unparseExp(e))) + end + | _ => primError(wrongArgKind(N.unparseFun_name,1,functionLCType,v))) + fun rootPrimUFun(v,env,ab) = (case coerceValIntoTerm(v) of SOME(t) => (case isGeneralApp(t) of diff --git a/topenv_part2.sml b/topenv_part2.sml index d9953db..dd2a2bc 100644 --- a/topenv_part2.sml +++ b/topenv_part2.sml @@ -2248,22 +2248,6 @@ fun hasEquality(P) = SOME(_,props) => List.exists hasEquality props | _ => raise Basic.Never)) -fun unparsePrimUFun(v,env,_) = - (case v of - closUFunVal(e,_,_,{name,...}) => - MLStringToAthString("Unary procedure: " ^ (!name) ^ (A.unparseExp(e))) - | closBFunVal(e,_,_,_,{name,...}) => - MLStringToAthString("Binary procedure: " ^ (!name) ^ (A.unparseExp(e))) - | closFunVal(e,_,{name,...}) => - MLStringToAthString("Procedure: " ^ (!name) ^ (A.unparseExp(e))) - | closUMethodVal(d,_,_,name) => - MLStringToAthString("Unary method: " ^ (!name) ^ (A.unparseDed(d))) - | closBMethodVal(d,_,_,_,name) => - MLStringToAthString("Binary method: " ^ (!name) ^ (A.unparseDed(d))) - | closMethodVal(e,_) => - MLStringToAthString("Method: " ^ (A.unparseExp(e))) - | _ => primError(wrongArgKind(N.unparseFun_name,1,functionLCType,v))) - fun make_CNF_Result(clauses,output_format,inverse_atom_table) = let fun makeAtom(i) = (case (HashTable.find inverse_atom_table i) of SOME(A) => A From f3385a40b17880fc9840e54ac67fa24f4eb49176 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Thu, 7 Nov 2024 20:58:08 -0500 Subject: [PATCH 44/49] WIP --- base.sig | 1 + base.sml | 8 ++ prop.sig | 3 +- simp.sml | 199 +++++++++++++++++++++++++++++++++++++++++++---- topenv_part1.sml | 9 ++- 5 files changed, 201 insertions(+), 19 deletions(-) diff --git a/base.sig b/base.sig index 44c4ddc..ebbf355 100755 --- a/base.sig +++ b/base.sig @@ -33,6 +33,7 @@ sig val writeString: string * char Array.array * int -> int val remove : ''a * ''a list -> ''a list val removeAll : ''a list * ''a list -> ''a list + val removeAllEq : 'a list * 'a list * ('a * 'a -> bool) -> 'a list val removeEq : 'a * 'a list * ('a * 'a ->bool) -> 'a list val removeAndCheckMemEq : 'a * 'a list * ('a * 'a ->bool) -> ('a list * bool) val zip : 'a list * 'b list -> ('a * 'b) list diff --git a/base.sml b/base.sml index 5a0ff64..ab4f37f 100755 --- a/base.sml +++ b/base.sml @@ -223,6 +223,7 @@ fun removeAll(L1,L2) = loop(L1,L2) end + fun removeEq(x,l,eq) = let fun remove([],res) = res | remove(y::ys,res) = if eq(x,y) then remove(ys,res) else remove(ys,y::res) @@ -230,6 +231,13 @@ fun removeEq(x,l,eq) = remove(l,[]) end +fun removeAllEq(L1,L2,f) = + let fun loop([],res) = res + | loop(x::more,res) = loop(more,removeEq(x,res,f)) + in + loop(L1,L2) + end + (* removeAndCheckMemEq also does not preserve order: *) fun removeAndCheckMemEq(x,l,eq) = diff --git a/prop.sig b/prop.sig index 7f9ac21..e25733e 100755 --- a/prop.sig +++ b/prop.sig @@ -29,7 +29,8 @@ sig val toPrettyStringDefault: int * prop -> string (* Alphabetic equivalence for Athena sentences - a fundamental relation: *) - val alEq: prop * prop -> bool + val alEq +: prop * prop -> bool (* Literal equality (unlike alpha equality): *) val literalEq: prop * prop -> bool diff --git a/simp.sml b/simp.sml index b11c4d8..05db3dd 100644 --- a/simp.sml +++ b/simp.sml @@ -29,27 +29,35 @@ fun getThreadElements(A.beginDed({members,...})) = Basic.flatten(map getThreadEl | getThreadElements(D) = [D]; +fun makeEvalExpFunction(env,ab) = + (fn (e,binding_map) => (case binding_map of + NONE => Semantics.evalExp(e,env,ab) + | SOME(map) => Semantics.evalExp(e,ref(Semantics.augmentWithMap(!env,map)),ab))) -fun getPropsAndEnv([],props,env,_) = (props,env) - | getPropsAndEnv((b:A.binding as {bpat,pos,def,...})::rest,props,env,ab) = - let val pval = Semantics.evalPhrase(def,env,ab) +fun getPropAndEnv(b:A.binding as {bpat,pos,def,...},env,ab) = + let val _ = Basic.mark("HERE WE ARE") + val pval = Semantics.evalPhrase(def,env,ab) + val _ = Basic.mark("UHOH...") in (case Semantics.coerceValIntoProp(pval) of SOME(p) => (case Semantics.matchPat(pval,bpat,makeEvalExpFunction (env,ab)) of SOME(map,_) => let val (vmap,mmap) = Semantics.getValAndModMaps(!env) val env' = ref(Semantics.valEnv({val_map=Symbol.augment(vmap,map),mod_map=mmap})) in - getPropsAndEnv(rest,p::props,env',ab) + (p,env') end - | _ => Basic.fail("Assume pattern failed to match the corresponding value.")) + | _ => Basic.fail("Pattern failed to match the corresponding value.")) | _ => Basic.fail("A sentence (hypothesis) was expected here...")) - end -and makeEvalExpFunction(env,ab) = - (fn (e,binding_map) => (case binding_map of - NONE => Semantics.evalExp(e,env,ab) - | SOME(map) => Semantics.evalExp(e,ref(Semantics.augmentWithMap(!env,map)),ab))) + end +fun getPropsAndEnv([],props,env,_) = (props,env) + | getPropsAndEnv((b:A.binding as {bpat,pos,def,...})::rest,props,env,ab) = + let val pval = Semantics.evalPhrase(def,env,ab) + val (p,env') = getPropAndEnv(b,env,ab) + in + getPropsAndEnv(rest,p::props,env',ab) + end fun getProp(phrase,env,ab) = (case Semantics.coerceValIntoPropVal(Semantics.evalPhrase(phrase,env,ab)) of @@ -142,13 +150,37 @@ fun getBiCondDefConclusion(p) = (SOME(p1,p2),SOME(p2',p1')) => Prop.makeBiConditional(p1,p2) | _ => Basic.fail("")))) + +fun complements(p1,p2) = Prop.alEq(p2,Prop.makeComplement(p1)) orelse Prop.alEq(p1,Prop.makeComplement(p2)) + fun getNegatedBiCondDefConclusion(p) = Basic.fail("") fun getDistConclusion(p) = Basic.fail("") -fun conclusion(D,starting_ab) = - let val _ = print("\nENTERING conclusion inside simp.sml...\n") - fun C(A.assumeDed({assumption,body,...}),env) = +fun getMpConclusion(p1,p2) = + (case Prop.isCond(p1) of + SOME(q1,q2) => if Prop.alEq(p2,q1) then q2 else Basic.fail("Invalid use of mp") + | _ => Basic.fail("Invalid use of mp: A conditional was expected as the first argument")) + +fun getMtConclusion(p1,p2) = + (case Prop.isCond(p1) of + SOME(q1,q2) => if complements(p2,q2) then Prop.makeComplement(q1) else Basic.fail("Invalid use of mt") + | _ => Basic.fail("Invalid use of mt: A conditional was expected as the first argument")) + +fun getDsylConclusion(p1,p2) = + (case Prop.isDisj(p1) of + SOME(q1::(more as (_::_::_))) => if complements(p2,q1) then Prop.makeDisjunction(more) else Basic.fail("Invalid use of mt") + | SOME([q1,q2]) => if complements(p2,q1) then q2 else if complements(p2,q2) then q1 else Basic.fail("Invalid use of dsyl") + | _ => Basic.fail("Invalid use of dsyl: a disjunction with at least 2 components was expected here.")) + +fun getFromComplementsConclusions(args) = + (case args of + [p,q1,q2] => p + | _ => Basic.fail("Invalid use of from-complements.")) + +val (proofConclusionTop,FATop) = +let fun conclusion(D,starting_env,starting_ab) = + let fun C(A.assumeDed({assumption,body,...}),env) = let val p = C(body,env) in (case Semantics.coerceValIntoProp(Semantics.evalPhrase(assumption,env,starting_ab)) of @@ -163,12 +195,45 @@ fun conclusion(D,starting_ab) = | C(A.infixAssumeDed({bindings,body,...}),env) = let val (props,new_env) = getPropsAndEnv(bindings,[],env,starting_ab) val hyps = rev(props) - val q = C(body,env) + val q = C(body,new_env) in (case hyps of [P] => Prop.makeConditional(P,q) | _ => Prop.makeConditional(Prop.makeConjunction(hyps),q)) end + | C(A.letDed({bindings, body, ...}),env) = + let (*** val _ = print("\nAbout to call getPropsAndEnv...\n") ***) + val (props,new_env) = getPropsAndEnv(bindings,[],env,starting_ab) + in + C(body,new_env) + end + | C(A.BMethAppDed({method,arg1,arg2,...}),env) = + let val p1 = getProp(arg1,env,starting_ab) + val p2 = getProp(arg2,env,starting_ab) + in + (case method of + A.idExp({msym, mods=[],sym,...}) => + (case Symbol.name(sym) of + "mp" => getMpConclusion(p1,p2) + | "mt" => getMtConclusion(p1,p2) + | "dsyl" => getDsylConclusion(p1,p2) + | "both" => Prop.makeConjunction([p1,p2]) + | "left-either" => Prop.makeDisjunction([p1,p2]) + | "right-either" => Prop.makeDisjunction([p1,p2]) + | "either" => Prop.makeDisjunction([p1,p2]) + | _ => Basic.fail("Unknown binary method, cannot compute conclusion...")) + | _ => Basic.fail("Cannot compute conclusions for BMethodApps where the operator is not an identifier.")) + end + | C(A.methodAppDed({method,args,...}),env) = + let val props = map (fn arg => getProp(arg,env,starting_ab)) args + in + (case method of + A.idExp({msym, mods=[],sym,...}) => + (case Symbol.name(sym) of + "from-complements" => getFromComplementsConclusions(props) + | _ => Basic.fail("Unknown method, cannot compute conclusion...")) + | _ => Basic.fail("Cannot compute conclusions for methodApps where the operator is not an identifier.")) + end | C(A.UMethAppDed({method,arg,...}),env) = let val p = getProp(arg,env,starting_ab) in @@ -199,8 +264,110 @@ fun conclusion(D,starting_ab) = | C(_) = Basic.fail("Unable to compute conclusions for this type of deduction.") in - C(D,SemanticValues.top_val_env) + C(D,starting_env) end - +and getSeqFAs(deds,env,ab) = + let fun loop([],fas_so_far,conclusions_so_far) = rev(fas_so_far) + | loop(member::more,fas_so_far,conclusions_so_far) = + let val member_fas = fa(member,env,ab) + val true_fas = Basic.removeAllEq(conclusions_so_far,member_fas,Prop.alEq) + val member_conclusion = conclusion(member,env,ab) + in + loop(more,true_fas@fas_so_far,member_conclusion::conclusions_so_far) + end + in + loop(deds,[],[]) + end +and faLoop([],fas_so_far,conclusions_so_far,env,ab) = (rev(fas_so_far),rev(conclusions_so_far),env) + | faLoop((b:A.binding as {bpat,pos,def,...})::more,fas_so_far,conclusions_so_far,env,ab) = + let val _ = Basic.mark("GPGP") + val (p,env') = getPropAndEnv(b,env,ab) + val _ = Basic.mark("DONE") + in + (case def of + A.ded(d) => + let val member_fas = fa(d,env,ab) + val true_fas = Basic.removeAllEq(conclusions_so_far,member_fas,Prop.alEq) + val member_conclusion = conclusion(d,env,ab) + in + faLoop(more,true_fas@fas_so_far,member_conclusion::conclusions_so_far,env',ab) + end + | _ => faLoop(more,fas_so_far,conclusions_so_far,env',ab)) + end +and fa(A.assumeDed({assumption,body,...}),env,ab) = + let val hypothesis = getProp(assumption,env,ab) + in + Basic.removeEq(hypothesis,fa(body,env,ab),Prop.alEq) + end + | fa(A.infixAssumeDed({bindings,body,...}),env,ab) = + let val (binding_fas,binding_conclusions,new_env) = faLoop(bindings,[],[],env,ab) + val (props,new_env') = getPropsAndEnv(bindings,[],env,ab) + val hyps = rev(props) + val conjuncts:Prop.prop list = List.concat (map Prop.decomposeConjunctionsStrict hyps) + val all_hyps = hyps@conjuncts +(**** + val _ = print("\nHere's new_env: " ^ (SemanticValues.envToString (!new_env))) +***) + val _ = Basic.mark("XXXXXXXXXXXXXXXXXX") + val body_fas = fa(body,new_env,ABase.augment(ab,all_hyps)) + val _ = Basic.mark("DDDDD") + val true_body_fas = Basic.removeAllEq(all_hyps,body_fas,Prop.alEq) + in + Basic.removeDuplicatesEq(true_body_fas@binding_fas,Prop.alEq) + end + | fa(A.letDed({bindings, body, ...}),env,ab) = + let val _ = Basic.mark("YYYYYYYYYYYYYYYYY") + val (binding_fas,binding_conclusions,env') = faLoop(bindings,[],[],env,ab) + val _ = print("FAs of bindings: " ^ (Basic.printListStr(binding_fas,fn p => Prop.toPrettyStringDefault(0,p),"\n"))) + val (body_fas,body_conclusion) = (fa(body,env',ab),conclusion(body,env',ab)) + + val true_body_fas = Basic.removeAllEq(binding_conclusions,body_fas,Prop.alEq) + in + Basic.removeDuplicatesEq(true_body_fas@binding_fas,Prop.alEq) + end + | fa(A.beginDed({members,...}),env,ab) = getSeqFAs(members,env,ab) + | fa(A.BMethAppDed({method,arg1,arg2,...}),env,ab) = + let val p1 = getProp(arg1,env,ab) + val p2 = getProp(arg2,env,ab) + in + (case method of + A.idExp({msym, mods=[],sym,...}) => + (case Symbol.name(sym) of + "mp" => [p1,p2] + | "left-either" => [p1] + | "right-either" => [p2] + | "either" => let val fas = ref([]) + val _ = if not(ABase.isMember(p1,ab)) then fas := [p1] else () + val _ = if not(ABase.isMember(p2,ab)) then fas := p1::(!fas) else () + in + !fas + end + | _ => [p1,p2]) + | _ => Basic.fail("Cannot compute free assumptions for BMethodApps where the operator is not an identifier.")) + end + | fa(A.UMethAppDed({method,arg,...}),env,ab) = + let val p = getProp(arg,env,ab) + in + (case method of + A.idExp({msym, mods=[],sym,...}) => + (case Symbol.name(sym) of + "ex-middle" => [] + | "from-false" => [] + | _ => [p]) + | _ => Basic.fail("Cannot compute free assumptions for UMethodApps where the operator is not an identifier.")) + end + | fa(D,_,_) = Basic.fail("Don't know how to do FAs on this type of proof yet: " ^ (A.unparseDed D)) +in + (fn (D,starting_env,starting_ab) => + let val res = conclusion(D,starting_env,starting_ab) + in + res + end, + fn (D,env,starting_ab) => fa(D,env,starting_ab)) +end + +fun proofConclusion(D,ab) = proofConclusionTop(D,SemanticValues.top_val_env,ab) + +fun FA(D,ab) = FATop(D,SemanticValues.top_val_env,ab) end; (* of structure Simplify_New *) diff --git a/topenv_part1.sml b/topenv_part1.sml index 6500b99..1b77a93 100755 --- a/topenv_part1.sml +++ b/topenv_part1.sml @@ -725,7 +725,7 @@ fun unparsePrimUFun(v,env,ab) = | closFunVal(e,_,{name,...}) => MLStringToAthString("Procedure: " ^ (!name) ^ (A.unparseExp(e))) | closUMethodVal(d,_,_,name) => - let val conc = Simplify_New.conclusion(d,ab) + let val conc = Simplify_New.proofConclusion(d,ab) val _ = print("\nCONCLUSION:\n" ^ (Prop.toPrettyStringDefault(0,conc)) ^ "\n") in MLStringToAthString("Unary method: " ^ (!name) ^ (A.unparseDed(d))) @@ -733,8 +733,13 @@ fun unparsePrimUFun(v,env,ab) = | closBMethodVal(d,_,_,_,name) => MLStringToAthString("Binary method: " ^ (!name) ^ (A.unparseDed(d))) | closMethodVal(e as A.methodExp({body,...}),_) => - let val conc = Simplify_New.conclusion(body,ab) + let val conc = Simplify_New.proofConclusion(body,ab) + val _ = Basic.mark("11111111") val _ = print("\nCONCLUSION:\n" ^ (Prop.toPrettyStringDefault(0,conc)) ^ "\n") + val _ = Basic.mark("2222222222222") + val fas = Simplify_New.FA(body,ab) + val _ = Basic.mark("33333333333333333") + val _ = print("\n[[[[[[[ FREE ASSUMPTIONS:\n" ^ (Basic.printListStr(fas,fn p => Prop.toPrettyStringDefault(0,p),"\n")) ^ "\n]]]]]]]\n") in MLStringToAthString("Method: " ^ (A.unparseExp(e))) end From cf006485c0406541eed3095d52cf0eb35de5627f Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Fri, 8 Nov 2024 10:15:59 -0500 Subject: [PATCH 45/49] WIP --- athena.grm | 1 - prop.sig | 2 ++ prop.sml | 5 +++ semantics.sml | 2 +- simp.sml | 80 ++++++++++++++++++++++++++++++++---------------- topenv_part1.sml | 5 +-- 6 files changed, 63 insertions(+), 32 deletions(-) diff --git a/athena.grm b/athena.grm index b44f1ed..e65813c 100755 --- a/athena.grm +++ b/athena.grm @@ -702,7 +702,6 @@ deduction: LPAREN expression BY deduction RPAREN (A.byDed({wanted_res=expressio (A.byCasesDed({disj=phrase,from_exps=NONE, arms=case_clauses,pos=getPos BY_CASESleft})) - | BY_CASES phrase FROM comma_separated_expression_list BEGIN case_clauses END (A.byCasesDed({disj=phrase,from_exps=SOME(comma_separated_expression_list), arms=case_clauses,pos=getPos BY_CASESleft})) diff --git a/prop.sig b/prop.sig index e25733e..b46e680 100755 --- a/prop.sig +++ b/prop.sig @@ -325,5 +325,7 @@ is specified as a string: dimacs_file_prep_time: real, sat_solving_time:real} + val isExMiddleInstance: prop -> bool + end diff --git a/prop.sml b/prop.sml index d432bef..3386ce4 100755 --- a/prop.sml +++ b/prop.sml @@ -4307,6 +4307,11 @@ fun renameSortVarsLst(props) = props' end +fun isExMiddleInstance(p) = + (case isDisj(p) of + SOME([p1,p2]) => alEq(p2,makeNegation(p1)) + | _ => false) + end (** of "abstype prop with..." **) end (** Of Prop structure **) diff --git a/semantics.sml b/semantics.sml index 49d68f7..9b8b174 100755 --- a/semantics.sml +++ b/semantics.sml @@ -3670,7 +3670,7 @@ and | _ => evError("A sentence (disjunction) was expected here. Instead, a\n"^ "value of type "^valLCTypeAndString(disj_val)^" was found.", SOME(A.posOfPhrase(disj)))) - val disj_holds = if ABase.isMember(disj_prop,ab) orelse A.isDeduction(disj) then true + val disj_holds = if ABase.isMember(disj_prop,ab) orelse A.isDeduction(disj) orelse Prop.isExMiddleInstance(disj_prop) then true else (case from_exps of NONE => evError("By-cases disjunction doesn't hold", diff --git a/simp.sml b/simp.sml index 05db3dd..9e73ca1 100644 --- a/simp.sml +++ b/simp.sml @@ -36,9 +36,7 @@ fun makeEvalExpFunction(env,ab) = fun getPropAndEnv(b:A.binding as {bpat,pos,def,...},env,ab) = - let val _ = Basic.mark("HERE WE ARE") - val pval = Semantics.evalPhrase(def,env,ab) - val _ = Basic.mark("UHOH...") + let val pval = Semantics.evalPhrase(def,env,ab) in (case Semantics.coerceValIntoProp(pval) of SOME(p) => (case Semantics.matchPat(pval,bpat,makeEvalExpFunction (env,ab)) of @@ -224,16 +222,6 @@ let fun conclusion(D,starting_env,starting_ab) = | _ => Basic.fail("Unknown binary method, cannot compute conclusion...")) | _ => Basic.fail("Cannot compute conclusions for BMethodApps where the operator is not an identifier.")) end - | C(A.methodAppDed({method,args,...}),env) = - let val props = map (fn arg => getProp(arg,env,starting_ab)) args - in - (case method of - A.idExp({msym, mods=[],sym,...}) => - (case Symbol.name(sym) of - "from-complements" => getFromComplementsConclusions(props) - | _ => Basic.fail("Unknown method, cannot compute conclusion...")) - | _ => Basic.fail("Cannot compute conclusions for methodApps where the operator is not an identifier.")) - end | C(A.UMethAppDed({method,arg,...}),env) = let val p = getProp(arg,env,starting_ab) in @@ -261,6 +249,20 @@ let fun conclusion(D,starting_env,starting_ab) = | _ => Basic.fail("Unknown unary method, cannot compute conclusion...")) | _ => Basic.fail("Cannot compute conclusions for UMethodApps where the operator is not an identifier.")) end + | C(A.methodAppDed({method,args,...}),env) = + let val props = map (fn arg => getProp(arg,env,starting_ab)) args + in + (case method of + A.idExp({msym, mods=[],sym,...}) => + (case Symbol.name(sym) of + "from-complements" => getFromComplementsConclusions(props) + | _ => Basic.fail("Unknown method, cannot compute conclusion...")) + | _ => Basic.fail("Cannot compute conclusions for methodApps where the operator is not an identifier.")) + end + | C(A.byCasesDed({disj,from_exps,arms,...}),env) = + (case arms of + [] => Basic.fail("At least one case arm was expected here.") + | (arm:A.case_clause as {proof,...})::_ => C(proof,env)) | C(_) = Basic.fail("Unable to compute conclusions for this type of deduction.") in @@ -280,9 +282,7 @@ and getSeqFAs(deds,env,ab) = end and faLoop([],fas_so_far,conclusions_so_far,env,ab) = (rev(fas_so_far),rev(conclusions_so_far),env) | faLoop((b:A.binding as {bpat,pos,def,...})::more,fas_so_far,conclusions_so_far,env,ab) = - let val _ = Basic.mark("GPGP") - val (p,env') = getPropAndEnv(b,env,ab) - val _ = Basic.mark("DONE") + let val (p,env') = getPropAndEnv(b,env,ab) in (case def of A.ded(d) => @@ -305,20 +305,14 @@ and fa(A.assumeDed({assumption,body,...}),env,ab) = val hyps = rev(props) val conjuncts:Prop.prop list = List.concat (map Prop.decomposeConjunctionsStrict hyps) val all_hyps = hyps@conjuncts -(**** - val _ = print("\nHere's new_env: " ^ (SemanticValues.envToString (!new_env))) -***) - val _ = Basic.mark("XXXXXXXXXXXXXXXXXX") val body_fas = fa(body,new_env,ABase.augment(ab,all_hyps)) - val _ = Basic.mark("DDDDD") val true_body_fas = Basic.removeAllEq(all_hyps,body_fas,Prop.alEq) in Basic.removeDuplicatesEq(true_body_fas@binding_fas,Prop.alEq) end | fa(A.letDed({bindings, body, ...}),env,ab) = - let val _ = Basic.mark("YYYYYYYYYYYYYYYYY") - val (binding_fas,binding_conclusions,env') = faLoop(bindings,[],[],env,ab) - val _ = print("FAs of bindings: " ^ (Basic.printListStr(binding_fas,fn p => Prop.toPrettyStringDefault(0,p),"\n"))) + let val (binding_fas,binding_conclusions,env') = faLoop(bindings,[],[],env,ab) + (** val _ = print("FAs of bindings: " ^ (Basic.printListStr(binding_fas,fn p => Prop.toPrettyStringDefault(0,p),"\n"))) **) val (body_fas,body_conclusion) = (fa(body,env',ab),conclusion(body,env',ab)) val true_body_fas = Basic.removeAllEq(binding_conclusions,body_fas,Prop.alEq) @@ -333,8 +327,7 @@ and fa(A.assumeDed({assumption,body,...}),env,ab) = (case method of A.idExp({msym, mods=[],sym,...}) => (case Symbol.name(sym) of - "mp" => [p1,p2] - | "left-either" => [p1] + "left-either" => [p1] | "right-either" => [p2] | "either" => let val fas = ref([]) val _ = if not(ABase.isMember(p1,ab)) then fas := [p1] else () @@ -356,6 +349,41 @@ and fa(A.assumeDed({assumption,body,...}),env,ab) = | _ => [p]) | _ => Basic.fail("Cannot compute free assumptions for UMethodApps where the operator is not an identifier.")) end + | fa(A.methodAppDed({method,args,...}),env,ab) = + let val props = map (fn p => getProp(p,env,ab)) args + in + (case method of + A.idExp({msym, mods=[],sym,...}) => + (case Symbol.name(sym) of + "from-complements" => tl(props) + | _ => props) + | _ => Basic.fail("Cannot compute free assumptions for methodApps where the operator is not an identifier.")) + end + | fa(input_ded as A.byCasesDed({disj,from_exps,arms,...}),env,ab) = +(*** +If from_exps is SOME(), then must produce a list of sentences, all of which will be members of the result (i.e., of FA(input_ded). ). +Otherwise, disj must produce a sentence, and that sentence will be a member of the result UNLESS disj is a deduction. +Finally, the FAs of all the proofs of all the arms will also be in the result. +***) + (case arms of + [] => Basic.fail("At least one case arm was expected here.") + | _ => let val disj_sentence = getProp(disj,env,ab) + val disj_sentences = if Prop.isExMiddleInstance(disj_sentence) then [] else [disj_sentence] + val arm_fas = List.concat (map (fn cc:A.case_clause as {alt,proof,...} => + let val alt_sentence = getProp(A.exp(alt),env,ab) + val proof_fas = Basic.removeEq(alt_sentence,fa(proof,env,ab),Prop.alEq) + in + proof_fas + end) + arms) + in + (case from_exps of + SOME(exps) => let val exp_sentences = map (fn e => getProp(A.exp(e),env,ab)) exps + in + disj_sentences @ exp_sentences @ arm_fas + end + | _ => (disj_sentences @ arm_fas)) + end) | fa(D,_,_) = Basic.fail("Don't know how to do FAs on this type of proof yet: " ^ (A.unparseDed D)) in (fn (D,starting_env,starting_ab) => diff --git a/topenv_part1.sml b/topenv_part1.sml index 1b77a93..688350d 100755 --- a/topenv_part1.sml +++ b/topenv_part1.sml @@ -734,12 +734,9 @@ fun unparsePrimUFun(v,env,ab) = MLStringToAthString("Binary method: " ^ (!name) ^ (A.unparseDed(d))) | closMethodVal(e as A.methodExp({body,...}),_) => let val conc = Simplify_New.proofConclusion(body,ab) - val _ = Basic.mark("11111111") val _ = print("\nCONCLUSION:\n" ^ (Prop.toPrettyStringDefault(0,conc)) ^ "\n") - val _ = Basic.mark("2222222222222") val fas = Simplify_New.FA(body,ab) - val _ = Basic.mark("33333333333333333") - val _ = print("\n[[[[[[[ FREE ASSUMPTIONS:\n" ^ (Basic.printListStr(fas,fn p => Prop.toPrettyStringDefault(0,p),"\n")) ^ "\n]]]]]]]\n") + val _ = print("\n[[[[[[[ FREE ASSUMPTIONS:\n\n" ^ (Basic.printListStr(fas,fn p => Prop.toPrettyStringDefault(0,p),"\n")) ^ "\n\n]]]]]]]\n") in MLStringToAthString("Method: " ^ (A.unparseExp(e))) end From 3b3d16fcd1a5a4cc8b8652fcd354ac77ee0c47c0 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Fri, 8 Nov 2024 11:26:40 -0500 Subject: [PATCH 46/49] Excluding deductive arguments from method-call FAs --- simp.sml | 63 +++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 56 insertions(+), 7 deletions(-) diff --git a/simp.sml b/simp.sml index 9e73ca1..5ebc5f4 100644 --- a/simp.sml +++ b/simp.sml @@ -213,6 +213,7 @@ let fun conclusion(D,starting_env,starting_ab) = A.idExp({msym, mods=[],sym,...}) => (case Symbol.name(sym) of "mp" => getMpConclusion(p1,p2) + | "by-contradiction" => p1 | "mt" => getMtConclusion(p1,p2) | "dsyl" => getDsylConclusion(p1,p2) | "both" => Prop.makeConjunction([p1,p2]) @@ -299,6 +300,11 @@ and fa(A.assumeDed({assumption,body,...}),env,ab) = in Basic.removeEq(hypothesis,fa(body,env,ab),Prop.alEq) end + | fa(A.absurdDed({hyp,body,...}),env,ab) = + let val hypothesis = getProp(hyp,env,ab) + in + Basic.removeEq(hypothesis,fa(body,env,ab),Prop.alEq) + end | fa(A.infixAssumeDed({bindings,body,...}),env,ab) = let val (binding_fas,binding_conclusions,new_env) = faLoop(bindings,[],[],env,ab) val (props,new_env') = getPropsAndEnv(bindings,[],env,ab) @@ -322,23 +328,27 @@ and fa(A.assumeDed({assumption,body,...}),env,ab) = | fa(A.beginDed({members,...}),env,ab) = getSeqFAs(members,env,ab) | fa(A.BMethAppDed({method,arg1,arg2,...}),env,ab) = let val p1 = getProp(arg1,env,ab) + val p1_lst = if A.isDeduction(arg1) then [] else [p1] val p2 = getProp(arg2,env,ab) + val p2_lst = if A.isDeduction(arg2) then [] else [p2] in (case method of A.idExp({msym, mods=[],sym,...}) => (case Symbol.name(sym) of - "left-either" => [p1] - | "right-either" => [p2] + "left-either" => p1_lst + | "right-either" => p2_lst | "either" => let val fas = ref([]) val _ = if not(ABase.isMember(p1,ab)) then fas := [p1] else () val _ = if not(ABase.isMember(p2,ab)) then fas := p1::(!fas) else () in !fas end - | _ => [p1,p2]) + | _ => p1_lst @ p2_lst) | _ => Basic.fail("Cannot compute free assumptions for BMethodApps where the operator is not an identifier.")) end | fa(A.UMethAppDed({method,arg,...}),env,ab) = + if A.isDeduction(arg) then [] + else let val p = getProp(arg,env,ab) in (case method of @@ -350,13 +360,16 @@ and fa(A.assumeDed({assumption,body,...}),env,ab) = | _ => Basic.fail("Cannot compute free assumptions for UMethodApps where the operator is not an identifier.")) end | fa(A.methodAppDed({method,args,...}),env,ab) = - let val props = map (fn p => getProp(p,env,ab)) args + let fun getAllNonDeds([],res) = rev(res) + | getAllNonDeds(phrase::more,res) = if A.isDeduction(phrase) then getAllNonDeds(more,res) else getAllNonDeds(more,(getProp(phrase,env,ab))::res) + val tail_props_non_deds = getAllNonDeds(tl args,[]) + val props_non_deds = if not(null(args)) andalso not(A.isDeduction(hd args)) then (getProp(hd args,env,ab))::tail_props_non_deds else tail_props_non_deds in (case method of A.idExp({msym, mods=[],sym,...}) => (case Symbol.name(sym) of - "from-complements" => tl(props) - | _ => props) + "from-complements" => tail_props_non_deds + | _ => props_non_deds) | _ => Basic.fail("Cannot compute free assumptions for methodApps where the operator is not an identifier.")) end | fa(input_ded as A.byCasesDed({disj,from_exps,arms,...}),env,ab) = @@ -368,7 +381,7 @@ Finally, the FAs of all the proofs of all the arms will also be in the result. (case arms of [] => Basic.fail("At least one case arm was expected here.") | _ => let val disj_sentence = getProp(disj,env,ab) - val disj_sentences = if Prop.isExMiddleInstance(disj_sentence) then [] else [disj_sentence] + val disj_sentences = if A.isDeduction(disj) orelse Prop.isExMiddleInstance(disj_sentence) then [] else [disj_sentence] val arm_fas = List.concat (map (fn cc:A.case_clause as {alt,proof,...} => let val alt_sentence = getProp(A.exp(alt),env,ab) val proof_fas = Basic.removeEq(alt_sentence,fa(proof,env,ab),Prop.alEq) @@ -398,4 +411,40 @@ fun proofConclusion(D,ab) = proofConclusionTop(D,SemanticValues.top_val_env,ab) fun FA(D,ab) = FATop(D,SemanticValues.top_val_env,ab) +fun makeStrict(D,ab) = + let fun ms(A.assumeDed({assumption,body,pos})) = A.assumeDed({assumption=assumption,body=ms(body),pos=pos}) + | ms(D as A.beginDed({members,pos})) = + let val members' = map ms members + fun loop([last_proof],retained) = A.beginDed({members=rev(last_proof::retained),pos=pos}) + | loop(D::(more as (_::_)),retained) = + let val D_conc = proofConclusion(D,ab) + val more_fas = FA(A.beginDed({members=more,pos=pos}),ab) + in + if Basic.isMemberEq(D_conc,more_fas,Prop.alEq) then loop(more,D::retained) else loop(more,retained) + end + val res = loop(members',[]) + in + res + end + | ms(A.infixAssumeDed({bindings,body,pos})) = + let val body' = ms(body) + fun loop([],bindings_so_far) = rev(bindings_so_far) + | loop((b:A.binding as {bpat,pos,def,...})::more,bindings_so_far) = + (case def of + A.ded(d) => loop(more,{bpat=bpat,pos=pos,def=A.ded(ms(d))}::bindings_so_far) + | _ => loop(more,b::bindings_so_far)) + val bindings' = loop(bindings,[]) + in + A.infixAssumeDed({bindings=bindings',body=body',pos=pos}) + end + | ms(A.letDed({bindings, body, ...})) = + let + in + Basic.fail("") + end + | ms(D) = D + in + ms(D) + end + end; (* of structure Simplify_New *) From 0fd4cbc148e89bed7a572201da3e8f33bfa9a891 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Fri, 8 Nov 2024 21:28:55 -0500 Subject: [PATCH 47/49] Added server.ath, reimplemented evaluate --- athena.mlb | 1 + athena.sml | 4 +++ lib/basic/server.ath | 14 ++++++++++ lib/basic/util.ath | 4 ++- names.sml | 3 +++ repl.sml | 30 +++++---------------- semantics.sml | 17 ++++++++++++ server.sml | 2 +- sockets.sml | 63 ++++++++++++-------------------------------- sources.cm | 14 +++++++++- topenv_part1.sml | 23 ++++++++++++++++ topenv_part2.sml | 35 +++++++----------------- 12 files changed, 113 insertions(+), 97 deletions(-) create mode 100644 lib/basic/server.ath diff --git a/athena.mlb b/athena.mlb index 37d9b63..27c9cf2 100755 --- a/athena.mlb +++ b/athena.mlb @@ -83,6 +83,7 @@ in smt_output.sml compiler.sml server.sml + simp.sml topenv_part1.sml topenv_part2.sml definition_processor.sml diff --git a/athena.sml b/athena.sml index 18931b5..fc3b5fb 100755 --- a/athena.sml +++ b/athena.sml @@ -28,6 +28,10 @@ fun run() = let val _ = Options.first_time := true in runWithStarterFile(NONE) end (** +fun run() = let val _ = Options.first_time := true + in ExpressServer.startServerOnPort(10000) end +**) +(** -- XSB-specific code, commented out by default: diff --git a/lib/basic/server.ath b/lib/basic/server.ath new file mode 100644 index 0000000..725379a --- /dev/null +++ b/lib/basic/server.ath @@ -0,0 +1,14 @@ +define client-request-size := 122880 + +(silence-on) + +define server := + (make-server client-request-size + lambda (str) + (catch lambda () (val->string (evaluate str)) + lambda (error_msg) + error_msg)) + +define port := 10000 + +(server port) \ No newline at end of file diff --git a/lib/basic/util.ath b/lib/basic/util.ath index e766901..a762840 100644 --- a/lib/basic/util.ath +++ b/lib/basic/util.ath @@ -5173,4 +5173,6 @@ define (replace-strings pat-replacement-pairs base) := (list-of [pat replacement] rest) => (replace-strings rest (replace-string pat replacement base)) | _ => base } - \ No newline at end of file + +define (silence-on) := (process-input-from-string "(set-flag silent-mode \"on\")") +define (silence-off) := (process-input-from-string "(set-flag silent-mode \"off\")") \ No newline at end of file diff --git a/names.sml b/names.sml index 38e1642..1ab2d08 100755 --- a/names.sml +++ b/names.sml @@ -324,6 +324,9 @@ val valToString_symbol' = Symbol.symbol valToString_name' val transOntologyFun_name = "translate-ontology" val transOntologyFun_symbol = Symbol.symbol transOntologyFun_name +val clientConnect_name = "client" +val clientConnect_symbol = Symbol.symbol clientConnect_name + val getABFun_name = "get-ab" val getABFun_symbol = Symbol.symbol getABFun_name val renameFun_name = "rename" diff --git a/repl.sml b/repl.sml index bbc3140..d6e37ce 100755 --- a/repl.sml +++ b/repl.sml @@ -40,22 +40,6 @@ fun printLoadedFiles(loaded_files : (string,bool) HashTable.hash_table) = fun debugPrint(_) = () -fun exceptionToString(e) = - let fun f(ErrorMsg.ParseError((l,p),str)) = ("\n"^A.posToString({line=l,file=(!Paths.current_file),pos=p})^": Parsing error, "^str^".\n") - | f(A.LexError(str,SOME(pos))) = ("\n"^A.posToString(pos)^": Lexical error, "^str^".\n") - | f(A.LexError(str,NONE)) = ((!Paths.current_file)^": Lexical error at end of file, "^str^".\n") - | f(A.SyntaxError(str,SOME(pos))) = ("\n"^(A.posToString pos)^": Syntax error: "^str^".\n") - | f(A.SyntaxError(str,NONE)) = ("\n"^(!Paths.current_file)^": Syntax error: "^str^".\n") - | f(Semantics.AthenaError(msg)) = ("\n"^msg^"\n") - | f(Semantics.EvalError(x)) = Semantics.makeErrorWithPosInfo(x) - | f(Data.GenEx(str)) = str^"\n" - | f(SemanticValues.GenEx(x as (msg,pos_opt))) = Semantics.makeErrorWithPosInfo(x) - | f(Basic.Fail(str)) = "\n"^str^"\n" - | f(Basic.FailLst(strings)) = "\n"^(Basic.printListStr(strings,fn x => x, "\n"))^"\n" - | f(_) = "\nUnknown error: "^(exnMessage e) - in - f e - end fun showFreeIds(phr,mod_path) = let val (new_phrase,vars,fids) = preProcessPhrase(phr,mod_path) @@ -140,7 +124,7 @@ in print(Semantics.summarizeTopCallStack())) end | TopEnv.Halt => () - | _ => print(exceptionToString(e))) + | _ => print(Semantics.exceptionToString(e))) end fun pathToString(path) = if null(path) then "[]" else Basic.printListStr(path,Symbol.name,".") @@ -337,7 +321,7 @@ and processModuleExtension(module:A.module_entry as {module_name,module_contents val _ = returned_env := SV.valEnv({val_map=val_map1',mod_map=Symbol.enter(mod_map1,mod_sym,new_module)}) in eval_env := SV.valEnv({val_map=val_map2,mod_map=Symbol.enter(mod_map2,mod_sym,new_module)}) - end handle ex => (error_msg := exceptionToString(ex); + end handle ex => (error_msg := Semantics.exceptionToString(ex); Paths.open_mod_paths := starting_open_mod_paths_val; Paths.open_mod_directives := starting_open_mod_directives_val; eval_env := starting_eval_env; @@ -408,7 +392,7 @@ and processModule(module:A.module_entry as {module_name,module_contents,module_f else () in () - end) handle ex => (error_msg := exceptionToString(ex); + end) handle ex => (error_msg := Semantics.exceptionToString(ex); Paths.open_mod_paths := starting_open_mod_paths_val; Paths.open_mod_directives := starting_open_mod_directives_val; eval_env := starting_eval_env; @@ -795,7 +779,7 @@ fun getInputAndProcess() = ((Parse.parse_from_stream istream),true,"") handle e => let val _ = Parse.setLinePos(1,0) in - ([],false,exceptionToString(e)) + ([],false,Semantics.exceptionToString(e)) end in if ok_input then @@ -837,9 +821,9 @@ fun escape(str) = fun processString(cmd,mod_path,env,eval_env) = let val stream = TextIO.openString (cmd) val inputs = Parse.parse_from_stream(stream) - val _ = List.app (fn i => (processInput(i,mod_path,env, Semantics.top_val_env, N.top_level_name,top_loaded_files_ht))) inputs - - in () + val responses = List.app (fn i => (processInput(i,mod_path,env, Semantics.top_val_env, N.top_level_name,top_loaded_files_ht))) inputs + in + () end val _ = (Semantics.processString := processString) diff --git a/semantics.sml b/semantics.sml index 9b8b174..1f726d1 100755 --- a/semantics.sml +++ b/semantics.sml @@ -71,6 +71,23 @@ fun builtIn(file) = fun makeErrorWithPosInfo(msg,SOME(pos)) = A.posToString(pos)^": Error: "^msg^"." | makeErrorWithPosInfo(msg,_) = msg +fun exceptionToString(e) = + let fun f(ErrorMsg.ParseError((l,p),str)) = ("\n"^A.posToString({line=l,file=(!Paths.current_file),pos=p})^": Parsing error, "^str^".\n") + | f(A.LexError(str,SOME(pos))) = ("\n"^A.posToString(pos)^": Lexical error, "^str^".\n") + | f(A.LexError(str,NONE)) = ((!Paths.current_file)^": Lexical error at end of file, "^str^".\n") + | f(A.SyntaxError(str,SOME(pos))) = ("\n"^(A.posToString pos)^": Syntax error: "^str^".\n") + | f(A.SyntaxError(str,NONE)) = ("\n"^(!Paths.current_file)^": Syntax error: "^str^".\n") + | f(AthenaError(msg)) = ("\n"^msg^"\n") + | f(EvalError(x)) = makeErrorWithPosInfo(x) + | f(Data.GenEx(str)) = str^"\n" + | f(SemanticValues.GenEx(x as (msg,pos_opt))) = makeErrorWithPosInfo(x) + | f(Basic.Fail(str)) = "\n"^str^"\n" + | f(Basic.FailLst(strings)) = "\n"^(Basic.printListStr(strings,fn x => x, "\n"))^"\n" + | f(_) = "\nUnknown error: "^(exnMessage e) + in + f e + end + fun evError(msg,pos_opt) = raise EvalError(msg,pos_opt) fun primError(str) = raise PrimError(str) diff --git a/server.sml b/server.sml index 4dadc7b..371944b 100755 --- a/server.sml +++ b/server.sml @@ -44,4 +44,4 @@ fun makeServerFun([termVal(t),cv],env,ab) = | makeServerFun(vals,env,ab) = primError(wrongArgNumber(N.makeServerFun_name,length(vals),2)) -end \ No newline at end of file +end diff --git a/sockets.sml b/sockets.sml index 029b069..ac9c13c 100755 --- a/sockets.sml +++ b/sockets.sml @@ -10,59 +10,30 @@ structure Socket = struct open TextIO -fun padMessageToServer(msg) = - let val len = String.size(msg) - val init_zero_count = 20 - len - val init_zero_segment = implode(map (fn _ => #"0") (Basic.fromI2N(1,init_zero_count))) - in - String.concat([init_zero_segment,msg]) - end - -fun chopPrefix(V,n) = - let val len = Word8Vector.length(V) - val len' = len - n - val L = List.tabulate(len',fn i => Word8Vector.sub(V,i+n)) +fun readAll conn req = + let val ntoread = Socket.Ctl.getNREAD conn in + if ntoread > 0 + then + let + val ntoreadMax1024x80 = if ntoread > 1024 * 80 then 1024 * 80 else ntoread; + val vec = Socket.recvVec (conn, ntoreadMax1024x80); + val vecLength = Word8Vector.length vec; + val reqSoFar = req ^ (String.substring (Byte.bytesToString vec, 0, vecLength)) in - Word8Vector.fromList(L) + if vecLength < ntoreadMax1024x80 + then reqSoFar + else readAll conn reqSoFar end - -fun getPayloadSize(V) = - let val first_20 = Byte.bytesToString(Word8Vector.fromList(List.tabulate(20,fn i => Word8Vector.sub(V,i)))) - in - (case Int.fromString(first_20) of - SOME(i) => i + 20 - | _ => 20) - end - -fun readAll(conn) = - let val payload_size = ref(1) - fun loop(vector_list,bytes_read_last_time,total_bytes_read_so_far,iteration) = - if ((total_bytes_read_so_far < !payload_size) andalso (bytes_read_last_time > 0)) then - let val in_vector = Socket.recvVec(conn,200000) - val len = Word8Vector.length(in_vector) - val _ = print("\nIteration #"^(Int.toString(iteration))^ - ", just read a chunk of length " ^ (Int.toString(len))) - val in_vector' = if iteration < 2 then - (payload_size := getPayloadSize(in_vector); - print("\nPAYLOAD SIZE: " ^ (Int.toString(!payload_size)) ^ "\n"); - chopPrefix(in_vector,20)) - else in_vector - in - loop(in_vector'::vector_list,len,len + total_bytes_read_so_far,iteration+1) - end - else rev(vector_list) - val vector_list = loop([],1,0,1) - in - Byte.bytesToString(Word8Vector.concat(vector_list)) - end; + else req + end; fun makeServer(input_buffer_size,processRequest) = fn port => let fun run(listener) = let fun accept() = let val (conn,conn_addr) = Socket.accept(listener) - val text = readAll(conn) + val text = readAll conn "" in - respond(conn,text); + respond(conn,text); accept() end and respond(conn,text) = let val reply = processRequest(text) @@ -79,7 +50,7 @@ fun makeServer(input_buffer_size,processRequest) = end handle x => (Socket.close(listener);raise x) in run(INetSock.TCP.socket()) - end handle x => (print("\nSomething went wrong...\n");raise x) + end handle e => (print("\nSomething went wrong" ^ (exnMessage e) ^ "\n");raise e) end diff --git a/sources.cm b/sources.cm index 45cce0b..39351e1 100755 --- a/sources.cm +++ b/sources.cm @@ -8,9 +8,12 @@ Group is $/basis.cm $smlnj/compiler/compiler.cm + $cml/cml.cm $/smlnj-lib.cm + $/inet-lib.cm + $/json-lib.cm $/ml-yacc-lib.cm - compat_11072.sml + compat_11072.sml ord_map.sig ord_map.sml inf_num.sig @@ -85,9 +88,18 @@ Group is smt_output.sml compiler.sml server.sml +(** + server2.sml +***) +(*** + client.sml +***) topenv_part1.sml topenv_part2.sml simp.sml +(** + athenaServer.sml +**) definition_processor.sml repl.sml athena.sml diff --git a/topenv_part1.sml b/topenv_part1.sml index 688350d..6cdb40f 100755 --- a/topenv_part1.sml +++ b/topenv_part1.sml @@ -4160,6 +4160,29 @@ fun eGenUniquePrimMethod([v1,v2],env,ab) = | eGenUniquePrimMethod(args,env,ab) = primError(wrongArgNumber(N.egenUniquePrimMethod_name,length(args),2)) + +fun catchPrimBFun(v1,v2,env,ab) = + (case (v1,v2) of + (closFunVal(e1,ref env1,_),closUFunVal(e2,arg_name,ref env2,_)) => + let val _ = (case (getClosureArity(v1),getClosureArity(v2)) of + (0,1) => () + | (0,n) => primError("The second procedure argument given to "^(N.catchFun_name)^" must take exactly one argument,\n"^ + "but here it takes "^(Int.toString(n))) + | (n,_) => primError("The first procedure argument given to "^(N.catchFun_name)^" must take zero arguments,\n"^ + "but here it takes "^(Int.toString(n)))) + in + ((evalClosure(v1,[],ab,NONE)) + handle e => let val str = MLStringToAthString(Semantics.exceptionToString(e)) + in + evalClosure(v2,[str],ab,NONE) + end) + end + | (closFunVal(_),v) => + + primError(wrongArgKind(N.catchFun_name,1,closFunLCType,v2)) + | (_,closFunVal(_)) => primError(wrongArgKind(N.catchFun_name,1,closFunLCType,v1))) + + end; diff --git a/topenv_part2.sml b/topenv_part2.sml index dd2a2bc..4bae2bf 100644 --- a/topenv_part2.sml +++ b/topenv_part2.sml @@ -336,26 +336,6 @@ fun compErrorPrimUFun(v,_,_) = SOME(msg) => makeAthenaError(msg) | _ => primError(wrongArgKind(N.compErrorFun_name,1,subLCType,v))) -fun catchPrimBFun(v1,v2,env,ab) = - (case (v1,v2) of - (closFunVal(e1,ref env1,_),closFunVal(e2,ref env2,_)) => - let val _ = (case (getClosureArity(v1),getClosureArity(v2)) of - (0,1) => () - | (0,n) => primError("The second procedure argument given to "^(N.catchFun_name)^" must take exactly one argument,\n"^ - "but here it takes "^(Int.toString(n))) - | (n,_) => primError("The first procedure argument given to "^(N.catchFun_name)^" must take zero arguments,\n"^ - "but here it takes "^(Int.toString(n)))) - in - ((evalClosure(v1,[],ab,NONE)) - handle EvalError(msg,_) => - let val str = MLStringToAthString(msg) - in - evalClosure(v2,[str],ab,NONE) - end) - end - | (closFunVal(_),_) => primError(wrongArgKind(N.catchFun_name,1,closFunLCType,v2)) - | (_,closFunVal(_)) => primError(wrongArgKind(N.catchFun_name,1,closFunLCType,v1))) - fun getMethodValClosureArity(closUMethodVal(_)) = 1 | getMethodValClosureArity(closBMethodVal(_)) = 2 | getMethodValClosureArity(closMethodVal(e,_)) = getMethodClosureArity(e) @@ -2974,6 +2954,10 @@ fun paradoxProvePrimFun([listVal(vals)],env,ab) = fun getABFun([],_,ab) = listVal(map propVal (ABase.getAll(ab))) +(*** +fun clientConnectFun([],_,ab) = let val _ = Client.connect(10000) in unitVal end +***) + fun getBucketSizesFun([],_,ab) = listVal(map (fn i => termVal(AthTerm.makeNumTerm(A.int_num(i,ref "")))) (ABase.bucketSizes())) fun showBucketStatisticsFun([],_,ab) = (print("\n"^(ABase.getBucketSizeStatistics())^"\n\n");unitVal) @@ -3333,12 +3317,10 @@ fun processPhraseFromStringFun([v],env:SemanticValues.value_environment ref,_) = print("\nAnd here's the TOP_VAL_ENV:[[[[[[[[\n" ^ SV.envToString(!top_val_env) ^ "\n]]]]]]]]\n") else () - val _ = if (false andalso !Options.fundef_mlstyle_option) then - print("\nAnd here's the EXTENDED environment, env';:[[[[[[[[\n" - ^ SV.envToString(!env') ^ "\n]]]]]]]]\n") - else () in processPhraseAndReturn(new_phrase,env',fids) end - | _ => primError("Incorrect application of "^(Names.evalFun_name)^".\nOnly phrases can be evaluated.")) + | _ => let val doString = !processString + val _ = doString(str,(!Paths.current_mod_path),ref(!env),env) + in unitVal end) in res_val end @@ -3651,6 +3633,9 @@ val init_val_bindings = [(N.not_symbol,propConVal(A.notCon)),(N.and_symbol,propC (Symbol.symbol("tsat0"),funVal(satSolve0,"tsat0",default_fv_pa_for_procs 1)), (N.fastSatFun_symbol,funVal(fastSatFun,N.fastSatFun_name,default_fv_pa_for_procs 2)), (N.getABFun_symbol,funVal(getABFun,N.getABFun_name,default_fv_pa_for_procs 0)), +(*** + (N.clientConnect_symbol,funVal(clientConnectFun,N.clientConnect_name,default_fv_pa_for_procs 0)), +***) (Symbol.symbol "get-bucket-sizes",funVal(getBucketSizesFun,"get-bucket-sizes",default_fv_pa_for_procs 0)), (Symbol.symbol "show-bucket-stats",funVal(showBucketStatisticsFun,"show-bucket-stats",default_fv_pa_for_procs 0)), (N.concatFun_symbol,funVal(concatFun,N.concatFun_name,default_fv_pa_for_procs 2)), From 3a425dc2e442d8ae158fe99bbee7e97b6980aebd Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Fri, 8 Nov 2024 21:37:14 -0500 Subject: [PATCH 48/49] Adding client.py --- client.py | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 client.py diff --git a/client.py b/client.py new file mode 100644 index 0000000..3d4701e --- /dev/null +++ b/client.py @@ -0,0 +1,53 @@ +import sys +sys.path.append('/mnt/c/code/python') +from utils1 import * +import socket + +def send_request_to_server(request: str,port=10000) -> str: + # Define server address and port + server_address = 'localhost' + # Create a TCP/IP socket + with socket.socket(socket.AF_INET, socket.SOCK_STREAM) as sock: + # Connect to the server + sock.connect((server_address, port)) + try: + # Send the request string encoded as bytes + sock.sendall(request.encode('utf-8')) + # Receive the response from the server + response = sock.recv(4096) # Buffer size is 4096 bytes + # Decode the response from bytes to a string + return response.decode('utf-8') + except Exception as e: + print(f"An error occurred: {e}") + return "" + +# Usage example +# Usage example +#response = send_request_to_server("Hello, server!") + + +s = "(plus 1 2)" +request = s +b = s.encode('utf-8') +port = 10000 +server_address = 'localhost' +#sock = socket.socket(socket.AF_INET, socket.SOCK_STREAM) + + +s = '''let {_ := (process-input-from-string "declare A, B, C, D, E, F, G, H: Boolean")} + assume h := (A & B) { + (!both (!right-and h) (!left-and h)) + } +''' + +#send_request_to_server('(process-input-from-string "(declare (A B C D E F G H) Boolean)")') + +s = '''assume h := (A & B) + (!both (!right-and h) (!left-and h)) +''' + + +s = '''assume h := (A & B) + (!both (!dn h) (!left-and h)) +''' + From 3325d60df234ae6fbcfe064826ad3f77c4788645 Mon Sep 17 00:00:00 2001 From: Konstantine Arkoudas Date: Sat, 9 Nov 2024 08:38:05 -0500 Subject: [PATCH 49/49] Minor cleanup --- sources.cm | 9 --------- topenv_part2.sml | 9 --------- 2 files changed, 18 deletions(-) diff --git a/sources.cm b/sources.cm index 39351e1..e27b633 100755 --- a/sources.cm +++ b/sources.cm @@ -88,18 +88,9 @@ Group is smt_output.sml compiler.sml server.sml -(** - server2.sml -***) -(*** - client.sml -***) topenv_part1.sml topenv_part2.sml simp.sml -(** - athenaServer.sml -**) definition_processor.sml repl.sml athena.sml diff --git a/topenv_part2.sml b/topenv_part2.sml index 4bae2bf..636af56 100644 --- a/topenv_part2.sml +++ b/topenv_part2.sml @@ -2954,12 +2954,6 @@ fun paradoxProvePrimFun([listVal(vals)],env,ab) = fun getABFun([],_,ab) = listVal(map propVal (ABase.getAll(ab))) -(*** -fun clientConnectFun([],_,ab) = let val _ = Client.connect(10000) in unitVal end -***) - -fun getBucketSizesFun([],_,ab) = listVal(map (fn i => termVal(AthTerm.makeNumTerm(A.int_num(i,ref "")))) (ABase.bucketSizes())) - fun showBucketStatisticsFun([],_,ab) = (print("\n"^(ABase.getBucketSizeStatistics())^"\n\n");unitVal) fun getAllFSymsFun([],_,_) = listVal(map (fn x => termConVal(SV.regFSym(x))) (Data.allFSyms())) @@ -3633,9 +3627,6 @@ val init_val_bindings = [(N.not_symbol,propConVal(A.notCon)),(N.and_symbol,propC (Symbol.symbol("tsat0"),funVal(satSolve0,"tsat0",default_fv_pa_for_procs 1)), (N.fastSatFun_symbol,funVal(fastSatFun,N.fastSatFun_name,default_fv_pa_for_procs 2)), (N.getABFun_symbol,funVal(getABFun,N.getABFun_name,default_fv_pa_for_procs 0)), -(*** - (N.clientConnect_symbol,funVal(clientConnectFun,N.clientConnect_name,default_fv_pa_for_procs 0)), -***) (Symbol.symbol "get-bucket-sizes",funVal(getBucketSizesFun,"get-bucket-sizes",default_fv_pa_for_procs 0)), (Symbol.symbol "show-bucket-stats",funVal(showBucketStatisticsFun,"show-bucket-stats",default_fv_pa_for_procs 0)), (N.concatFun_symbol,funVal(concatFun,N.concatFun_name,default_fv_pa_for_procs 2)),