From dccb72befef2081e5e3a59c63d3b5cd5955d8c7d Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Tue, 13 Jan 2009 16:58:31 +0100
Subject: [PATCH] Define involutary words with "define-involution"

---
 extra/inverse/inverse-docs.factor  | 9 +++++++--
 extra/inverse/inverse-tests.factor | 2 ++
 extra/inverse/inverse.factor       | 8 +++++---
 3 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor
index c2615fc411..6b575d6d08 100644
--- a/extra/inverse/inverse-docs.factor
+++ b/extra/inverse/inverse-docs.factor
@@ -14,12 +14,17 @@ 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-dual define-pop-inverse } ;
+{ $see-also define-dual define-involution 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 } ;
+{ $see-also define-inverse define-involution } ;
+
+HELP: define-involution
+{ $values { "word" "a word" } }
+{ $description "Defines a word as being its own inverse." }
+{ $see-also define-dual 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 3dce620857..a9234fcff4 100644
--- a/extra/inverse/inverse-tests.factor
+++ b/extra/inverse/inverse-tests.factor
@@ -78,3 +78,5 @@ C: <nil> nil
 
 [ [ sq ] ] [ [ sqrt ] [undo] ] unit-test
 [ [ sqrt ] ] [ [ sq ] [undo] ] unit-test
+[ [ not ] ] [ [ not ] [undo] ] unit-test
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index ec4df1ba69..924a6d3814 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -23,6 +23,8 @@ M: fail summary drop "Matching failed" ;
 : define-dual ( word1 word2 -- )
     2dup swap [ 1quotation define-inverse ] 2bi@ ;
 
+: define-involution ( word -- ) dup 1quotation define-inverse ;
+
 : define-math-inverse ( word quot1 quot2 -- )
     pick 1quotation 3array "math-inverse" set-word-prop ;
 
@@ -132,18 +134,18 @@ MACRO: undo ( quot -- ) [undo] ;
 
 ! Inverse of selected words
 
-\ swap [ swap ] define-inverse
+\ swap define-involution
 \ dup [ [ =/fail ] keep ] define-inverse
 \ 2dup [ over =/fail over =/fail ] define-inverse
 \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
 \ pick [ [ pick ] dip =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
-\ not [ not ] define-inverse
+\ not define-involution
 \ >boolean [ { t f } memq? assure ] define-inverse
 
 \ tuple>array \ >tuple define-dual
-\ reverse [ reverse ] define-inverse
+\ reverse define-involution
 
 \ undo 1 [ [ call ] curry ] define-pop-inverse
 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse