Definieren Sie einen Prädikatstypen "stringupper", dessen Werte alle Strings sind, die keine Kleinbuchstaben enthalten.

USING: unicode.case ;
PREDICATE: stringupper < string upper? ;

[ f ] [ "hello" stringupper? ] unit-test
[ t ] [ "HELLO" stringupper? ] unit-test
[ t ] [ "HELLO WORLD" stringupper? ] unit-test
[ t ] [ "" stringupper? ] unit-test
[ t ] [ " " stringupper? ] unit-test
[ t ] [ "12" stringupper? ] unit-test
[ f ] [ "ABC a" stringupper? ] unit-test

Definieren Sie einen Prädikatstypen "by7", der alle positiven Ganzzahlen enthält, die durch 7 teilbar sind.

PREDICATE: by7 < integer dup 0 > swap 7 mod 0 = and ;

[ t ] [ 7 by7? ] unit-test
[ t ] [ 14 by7? ] unit-test
[ t ] [ 7000 by7? ] unit-test
[ f ] [ 7.0 by7? ] unit-test
[ f ] [ 0 by7? ] unit-test
[ f ] [ -7 by7? ] unit-test


Definieren Sie einen Typen stringintfloat, der eine UNION aus strings, integers und floats ist.

UNION: stringintfloat string integer float ;

[ t ] [ 23 stringintfloat? ] unit-test
[ t ] [ "hello" stringintfloat? ] unit-test
[ t ] [ 3.4 stringintfloat? ] unit-test
[ f ] [ t stringintfloat? ] unit-test

Definieren Sie einen Typen boolint, der ein MIXIN aus booleans und integers ist.

MIXIN: boolint
INSTANCE: boolean boolint
INSTANCE: integer boolint

[ t ] [ 23 boolint? ] unit-test
[ t ] [ t boolint? ] unit-test
[ t ] [ f boolint? ] unit-test
[ f ] [ "" boolint? ] unit-test
[ f ] [ 3.4 boolint? ] unit-test

Definieren Sie einen Prädikatstypen quot1, der alle Quotations mit einem einzigen Element beinhaltet. 
Definieren Sie einen Prädikatstypen quot-string, der alle Quotations beinhaltet, deren erstes Element ein String ist.
Definieren Sie einen Schnittmengentypen quot-string1, der alle Quotations beinhaltet, die ein einziges Element vom Typ String enthalten.

USING: quotations ;
PREDICATE: quot1 < quotation length 1 = ;

[ t ] [ [ 1 ] quot1? ] unit-test
[ t ] [ [ "hello" ] quot1? ] unit-test
[ t ] [ [ [ ] ] quot1? ] unit-test
[ f ] [ [ ] quot1? ] unit-test
[ f ] [ [ 1 2 ] quot1? ] unit-test

USING: quotations ;
PREDICATE: quot-string < quotation dup empty? not [ first string? ] [ drop f ] if ;

[ t ] [ [ "" ] quot-string? ] unit-test
[ t ] [ [ "hello" "world" ] quot-string? ] unit-test
[ t ] [ [ "hello" 1 2 3 ] quot-string? ] unit-test
[ f ] [ [ 100 ] quot-string? ] unit-test
[ f ] [ [ ] quot-string? ] unit-test
[ f ] [ [ t " "] quot-string? ] unit-test

INTERSECTION: quot-string1 quot-string quot1 ;

[ t ] [ [ "" ] quot-string1? ] unit-test
[ t ] [ [ "hello" ] quot-string1? ] unit-test
[ f ] [ [ "hello" "world" ] quot-string1? ] unit-test
[ f ] [ [ "hello" 1 ] quot-string1? ] unit-test
[ f ] [ [ t ] quot-string1? ] unit-test


Definieren Sie mit Hilfe von drei Singletons einen Typen trafficlightcolor, der die Werte red, yellow, red-yellow und green enthält.

SINGLETON: red
SINGLETON: red-yellow
SINGLETON: yellow
SINGLETON: green
UNION: trafficlightcolor red red-yellow yellow green ;

[ t ] [ red trafficlightcolor? ] unit-test
[ t ] [ green trafficlightcolor? ] unit-test
[ t ] [ yellow trafficlightcolor? ] unit-test
[ t ] [ red-yellow trafficlightcolor? ] unit-test
[ f ] [ "green" trafficlightcolor? ] unit-test

Definieren Sie ein Wort next-color, das auf trafficlightcolors arbeitet und jeweils die nächste Farbe liefert. Legen Sie die deutsche STVO zugrunde.

: next-color ( color -- color' )
[
[ red [ red-yellow ] ]
[ red-yellow [ green ] ]
[ yellow [ red ] ]
[ green [ yellow ] ]
]
case ;

[ red-yellow ] [ red next-color ] unit-test
[ green ] [ red-yellow next-color ] unit-test
[ yellow ] [ green next-color ] unit-test
[ red ] [ yellow next-color ] unit-test
[ green ] [ red next-color next-color ] unit-test

Definieren Sie einen Typen ziffer, der nur die Zahlen 0 bis 9 enthält.

PREDICATE: ziffer < integer dup 0 >= swap 9 <= and ;

[ t ] [ 0 ziffer? ] unit-test
[ t ] [ 9 ziffer? ] unit-test
[ f ] [ 10 ziffer? ] unit-test
[ f ] [ -1 ziffer? ] unit-test
[ f ] [ 2.0 ziffer? ] unit-test

Definieren Sie ein Wort next-ziffer, das den Nachfolger einer Ziffer liefert. Der Nachfolger von 9 soll 0 sein.

: next-ziffer ( z -- z' ) dup 9 = [ drop 0 ] [ 1 + ] if ;

[ 1 ] [ 0 next-ziffer ] unit-test 
[ 3 ] [ 2 next-ziffer ] unit-test
[ 0 ] [ 9 next-ziffer ] unit-test

Definieren Sie ein generisches Wort next, das auf Ampelfarben und Ziffern arbeiten kann.

GENERIC: next ( obj -- obj' )
M: trafficlightcolor next next-color ;
M: ziffer next next-ziffer ;

[ 0 ] [ 9 next ] unit-test
[ green ] [ red-yellow next ] unit-test


Definieren Sie mit Hilfe von Singletons einen Vereinigungstypen sysstate. Die Werte von sysstate sind on, off, sleep.

SINGLETON: on
SINGLETON: off
SINGLETON: sleep
UNION: sysstate on off sleep ;

[ t ] [ on sysstate? ] unit-test
[ t ] [ off sysstate? ] unit-test
[ t ] [ sleep sysstate? ] unit-test
[ f ] [ "sleep" sysstate? ] unit-test

Definieren Sie eine Tupelklasse computer, die einen einziges Feld state hat. Dieses Feld muss vom Typ sysstate sein und hat standardmäßig den Wert off. 

TUPLE: computer { state sysstate initial: off } ;

[ t ] [ computer new state>> sysstate? ] unit-test
[ t ] [ computer new state>> off = ] unit-test

Die Methoden push-short und push-long arbeiten mit computer-Instanzen. Sie implementieren was passiert, wenn der Anschaltknopf eines Computers betätigt wird. Die Methode push-short steht für einen kurzen Knopfdruck, push-long für einen langen. Ist der Computer an, bewirkt ein kurzer Knopfdruck den Wechsel in den Schlafmodus, ein langer Knopfdruck schaltet den Computer aus. Ist der Computer im Schlafmodus, schaltet ein kurzer Knopfdruck den Computer an, ein langer Knopfdruck schaltet den Computer aus. Ist der Computer aus, schalten sowohl kurze als auch lange Knopfdrücke diesen an. Definieren Sie diese Methoden.

GENERIC: push-short ( obj -- obj' )
GENERIC: push-long ( obj -- obj' )

M: computer push-short 
dup state>> 
{ { on    [ sleep ] } 
  { off   [ on ] } 
  { sleep [ on ] } 
} case 
>>state ;

M: computer push-long  
dup state>> 
{ { on    [ off ] } 
  { off   [ on ] } 
  { sleep [ off ] } 
} case 
>>state ;

[ t ] [ computer new push-short state>> on = ] unit-test
[ t ] [ computer new push-short push-short state>> sleep = ] unit-test
[ t ] [ computer new push-short push-short push-short state>> on = ] unit-test
[ t ] [ computer new push-long state>> on = ] unit-test
[ t ] [ computer new push-long push-long state>> off = ] unit-test
[ t ] [ computer new push-long push-short push-long state>> off = ] unit-test

Die Tupelklassen laptop und desktop sind beides computer. laptop hat ein zusätzliches Feld on-battery vom Typ boolean, welches initial den Werf f hat. Das Verhalten der An- und Ausschaltknöpfe hängt davon ab, ob das Laptop im Batteriebetrieb ist oder nicht. Ist Batteriebetrieb aktiviert, ist alles wie für computer definiert, falls nicht, wecken sowohl kurze als auch lange Tastendrücke das Laptop auf.

TUPLE: laptop < computer { on-battery boolean initial: f } ;
TUPLE: desktop < computer ;

M: laptop push-long  
dup state>> 
{ { on    [ off ] } 
  { off   [ on ] } 
  { sleep [ dup on-battery>> [ off ] [ on ] if ] }
} case 
>>state ;


[ t ] [ laptop computer subclass-of? ] unit-test
[ t ] [ desktop computer subclass-of? ] unit-test

[ f ] [ laptop new on-battery>> ] unit-test
[ t ] [ laptop new push-short state>> on = ] unit-test
[ t ] [ laptop new push-short push-short push-long state>> on = ] unit-test
[ t ] [ laptop new t >>on-battery push-short push-short push-long state>> off = ] unit-test

[ t ] [ desktop new push-short state>> on = ] unit-test
[ t ] [ desktop new push-short push-short state>> sleep = ] unit-test
[ t ] [ desktop new push-short push-short push-short state>> on = ] unit-test
[ t ] [ desktop new push-long state>> on = ] unit-test
[ t ] [ desktop new push-long push-long state>> off = ] unit-test
[ t ] [ desktop new push-long push-short push-long state>> off = ] unit-test
[ f ] [ laptop new on-battery>> ] unit-test
[ t ] [ laptop new push-short state>> on = ] unit-test
[ t ] [ laptop new push-short push-short push-long state>> on = ] unit-test
[ t ] [ laptop new t >>on-battery push-short push-short push-long state>> off = ] unit-test


Bilden Sie das obige Beispiel ohne die Verwendung von Tupelvererbung über ein Mixin namens standby ab. 

MIXIN: standby
SINGLETON: on
SINGLETON: off
SINGLETON: sleep
UNION: sysstate on off sleep ;

GENERIC: push-short ( obj -- obj' )
GENERIC: push-long ( obj -- obj' )

M: standby push-short dup state>> { { on [ sleep ] } { off [ on ] } { sleep [ on ] } } case >>state ;

M: standby push-long  dup state>> { { on [ off ] } { off [ on ] } { sleep [ off ] } } case >>state ;

TUPLE: laptop { state sysstate initial: off } { on-battery boolean initial: f } ;

INSTANCE: laptop standby

M: laptop push-long  dup state>> { { on [ off ] } { off [ on ] } { sleep [ dup on-battery>> [ off ] [ on ] if ] } } case >>state ;

TUPLE: desktop { state sysstate initial: off } ;
INSTANCE: desktop standby


[ t ] [ desktop new push-short state>> on = ] unit-test
[ t ] [ desktop new push-short push-short state>> sleep = ] unit-test
[ t ] [ desktop new push-short push-short push-short state>> on = ] unit-test
[ t ] [ desktop new push-long state>> on = ] unit-test
[ t ] [ desktop new push-long push-long state>> off = ] unit-test
[ t ] [ desktop new push-long push-short push-long state>> off = ] unit-test
[ f ] [ laptop new on-battery>> ] unit-test
[ t ] [ laptop new push-short state>> on = ] unit-test
[ t ] [ laptop new push-short push-short push-long state>> on = ] unit-test
[ t ] [ laptop new t >>on-battery push-short push-short push-long state>> off = ] unit-test

[ t ] [ desktop new standby? ] unit-test
[ t ] [ laptop new standby? ] unit-test
[ 2 ] [ laptop superclasses length ] unit-test
[ 2 ] [ desktop superclasses length ] unit-test