From 280564b6ecd6321dbf1d2a5615b09d61d8e52dbe Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Tue, 13 Jan 2009 16:39:34 +0100
Subject: [PATCH] Define reciprocal inverses with "define-dual"

---
 extra/inverse/inverse-docs.factor  |  7 ++++++-
 extra/inverse/inverse-tests.factor |  3 +++
 extra/inverse/inverse.factor       | 15 +++++++--------
 3 files changed, 16 insertions(+), 9 deletions(-)

diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor
index 8204f7174c..c2615fc411 100644
--- a/extra/inverse/inverse-docs.factor
+++ b/extra/inverse/inverse-docs.factor
@@ -14,7 +14,12 @@ HELP: undo
 HELP: define-inverse
 { $values { "word" "a word" } { "quot" "the inverse" } }
 { $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." }
-{ $see-also define-pop-inverse } ;
+{ $see-also define-dual define-pop-inverse } ;
+
+HELP: define-dual
+{ $values { "word1" "a word" } { "word2" "a word" } }
+{ $description "Defines the inverse of each word as being the other one." }
+{ $see-also define-inverse } ;
 
 HELP: define-pop-inverse
 { $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } }
diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor
index 5e662ed78f..3dce620857 100644
--- a/extra/inverse/inverse-tests.factor
+++ b/extra/inverse/inverse-tests.factor
@@ -75,3 +75,6 @@ C: <nil> nil
 [ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test
 [ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail
 [ { 1 2 3 } [ { 2 3 } prepend ] undo ] must-fail
+
+[ [ sq ] ] [ [ sqrt ] [undo] ] unit-test
+[ [ sqrt ] ] [ [ sq ] [undo] ] unit-test
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index b9e0788192..ec4df1ba69 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -20,6 +20,9 @@ M: fail summary drop "Matching failed" ;
 
 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
 
+: define-dual ( word1 word2 -- )
+    2dup swap [ 1quotation define-inverse ] 2bi@ ;
+
 : define-math-inverse ( word quot1 quot2 -- )
     pick 1quotation 3array "math-inverse" set-word-prop ;
 
@@ -139,17 +142,14 @@ MACRO: undo ( quot -- ) [undo] ;
 \ not [ not ] define-inverse
 \ >boolean [ { t f } memq? assure ] define-inverse
 
-\ tuple>array [ >tuple ] define-inverse
-\ >tuple [ tuple>array ] define-inverse
+\ tuple>array \ >tuple define-dual
 \ reverse [ reverse ] define-inverse
 
 \ undo 1 [ [ call ] curry ] define-pop-inverse
 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
 
-\ exp [ log ] define-inverse
-\ log [ exp ] define-inverse
-\ sq [ sqrt ] define-inverse
-\ sqrt [ sq ] define-inverse
+\ exp \ log define-dual
+\ sq \ sqrt define-dual
 
 ERROR: missing-literal ;
 
@@ -203,8 +203,7 @@ DEFER: _
 \ first3 [ 3array ] define-inverse
 \ first4 [ 4array ] define-inverse
 
-\ prefix [ unclip ] define-inverse
-\ unclip [ prefix ] define-inverse
+\ prefix \ unclip define-dual
 \ suffix [ dup but-last swap peek ] define-inverse
 
 \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse