From 868ad064261efec4a197c4a2ff1df4dc56ddbccb Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Tue, 14 Oct 2008 15:05:05 +1100
Subject: [PATCH] Adding hats

---
 extra/hats/authors.txt       |  1 +
 extra/hats/hats-tests.factor | 87 ++++++++++++++++++++++++++++++++++++
 extra/hats/hats.factor       | 57 +++++++++++++++++++++++
 extra/hats/summary.txt       |  1 +
 4 files changed, 146 insertions(+)
 create mode 100644 extra/hats/authors.txt
 create mode 100644 extra/hats/hats-tests.factor
 create mode 100644 extra/hats/hats.factor
 create mode 100644 extra/hats/summary.txt

diff --git a/extra/hats/authors.txt b/extra/hats/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/hats/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/extra/hats/hats-tests.factor b/extra/hats/hats-tests.factor
new file mode 100644
index 0000000000..ebb61a0830
--- /dev/null
+++ b/extra/hats/hats-tests.factor
@@ -0,0 +1,87 @@
+! Copyright (C) 2008 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: boxes hats kernel namespaces symbols tools.test ;
+IN: hats.tests
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! caps
+[ rabbit ] [ rabbit <cap> out ] unit-test
+[ rabbit ] [ f <cap> rabbit in out ] unit-test
+[ rabbit ] [ rabbit <cap> take ] unit-test
+[ f ] [ rabbit <cap> empty-hat out ] unit-test
+[ rabbit f ] [ rabbit <cap> [ take ] keep out ] unit-test
+[ rabbit t ] [ rabbit <cap> [ take ] keep empty-hat? ] unit-test
+[ lion ] [ rabbit <cap> [ drop lion ] change-hat out ] unit-test
+
+! bowlers
+[ giraffe ] [ [ giraffe rabbit set rabbit <bowler> out ] with-scope ] unit-test
+
+[ rabbit ]
+[
+    [
+        lion rabbit set [
+            rabbit rabbit set rabbit <bowler> out
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ rabbit ] [
+    rabbit <bowler>
+    [
+        lion rabbit set [
+            rabbit rabbit set out
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ elephant ] [
+    rabbit <bowler>
+    [
+        elephant rabbit set [
+            rabbit rabbit set
+        ] with-scope
+        out
+    ] with-scope
+] unit-test
+
+[ rabbit ] [
+    rabbit <bowler>
+    [
+        elephant in [
+            rabbit in out
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ elephant ] [
+    rabbit <bowler>
+    [
+        elephant in [
+            rabbit in
+        ] with-scope
+        out
+    ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <top-hat> out ] unit-test
+[ giraffe ] [ rabbit <top-hat> giraffe in out ] unit-test
+
+! Tuple hats
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+    rabbit <foo> ;
+
+: test-slot-hat ( -- slot-hat )
+    test-tuple 2 <slot-hat> ; ! hack!
+
+[ rabbit ] [ test-slot-hat out ] unit-test
+[ lion ] [ test-slot-hat lion in out ] unit-test
+
+! Boxes as hats
+[ rabbit ] [ <box> rabbit in out ] unit-test
+[ <box> rabbit in lion in ] must-fail
+[ <box> out ] must-fail
diff --git a/extra/hats/hats.factor b/extra/hats/hats.factor
new file mode 100644
index 0000000000..113705bd11
--- /dev/null
+++ b/extra/hats/hats.factor
@@ -0,0 +1,57 @@
+! Copyright (C) 2008 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors boxes kernel namespaces ;
+IN: hats
+
+! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat!
+! Rocky: But that trick never works!
+! Bullwinkle: This time for sure!
+
+! hat protocol
+MIXIN: hat
+
+GENERIC: out ( hat -- object )
+GENERIC: (in) ( object hat -- )
+
+: in ( hat object -- hat ) over (in) ; inline
+: empty-hat? ( hat -- ? ) out not ; inline
+: empty-hat ( hat -- hat ) f in ; inline
+: take ( hat -- object ) dup out f rot (in) ; inline
+: change-hat ( hat quot -- hat )
+    over >r >r out r> call r> swap in ; inline
+
+! caps (the simplest of hats)
+TUPLE: cap object ;
+C: <cap> cap
+M: cap out ( cap -- object ) object>> ;
+M: cap (in) ( object cap -- ) (>>object) ;
+INSTANCE: cap hat
+
+! bowlers (dynamic variable hats)
+TUPLE: bowler variable ;
+C: <bowler> bowler
+M: bowler out ( bowler -- object ) variable>> get ;
+M: bowler (in) ( object bowler -- ) variable>> set ;
+INSTANCE: bowler hat
+
+! Top Hats (global variable hats)
+TUPLE: top-hat variable ;
+C: <top-hat> top-hat
+M: top-hat out ( top-hat -- object ) variable>> get-global ;
+M: top-hat (in) ( object top-hat -- ) variable>> set-global ;
+INSTANCE: top-hat hat
+
+USE: slots.private
+! Slot hats
+TUPLE: slot-hat tuple slot ;
+C: <slot-hat> slot-hat
+: >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ;
+M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ;
+INSTANCE: slot-hat hat
+
+! Put a box on your head
+M: box out ( box -- object ) box> ;
+M: box (in) ( object box -- ) >box ;
+INSTANCE: box hat
+
diff --git a/extra/hats/summary.txt b/extra/hats/summary.txt
new file mode 100644
index 0000000000..9590639922
--- /dev/null
+++ b/extra/hats/summary.txt
@@ -0,0 +1 @@
+A protocol for getting and setting