Merge branch 'experimental' of git://factorcode.org/git/wrunt
Slava Pestov
commit
2ff8cd14e9
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays assocs classes compiler db
|
||||
hashtables io.files kernel math math.parser namespaces
|
||||
hashtables io.files io.files.tmp kernel math math.parser namespaces
|
||||
prettyprint sequences strings tuples alien.c-types
|
||||
continuations db.sqlite.lib db.sqlite.ffi db.tuples
|
||||
words combinators.lib db.types combinators tools.walker
|
||||
|
|
@ -22,14 +22,22 @@ M: sqlite-db db-close ( handle -- )
|
|||
|
||||
M: sqlite-db dispose ( db -- ) dispose-db ;
|
||||
|
||||
: with-sqlite ( path quot -- )
|
||||
sqlite-db swap with-db ; inline
|
||||
|
||||
: with-tmp-sqlite ( quot -- )
|
||||
".db" [
|
||||
swap with-sqlite
|
||||
] with-tmpfile ;
|
||||
|
||||
TUPLE: sqlite-statement ;
|
||||
|
||||
TUPLE: sqlite-result-set has-more? ;
|
||||
|
||||
M: sqlite-db <simple-statement> ( str -- obj )
|
||||
M: sqlite-db <simple-statement> ( str in out -- obj )
|
||||
<prepared-statement> ;
|
||||
|
||||
M: sqlite-db <prepared-statement> ( str -- obj )
|
||||
M: sqlite-db <prepared-statement> ( str in out -- obj )
|
||||
{
|
||||
set-statement-sql
|
||||
set-statement-in-params
|
||||
|
|
|
|||
|
|
@ -84,6 +84,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
|
|||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
! break
|
||||
dup class db-columns find-primary-key assigned-id? [
|
||||
insert-assigned
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
USING: digraphs kernel sequences tools.test ;
|
||||
IN: digraphs.tests
|
||||
|
||||
: test-digraph ( -- digraph )
|
||||
<digraph>
|
||||
{ { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each
|
||||
{ { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ;
|
||||
|
||||
[ 5 ] [ test-digraph topological-sort length ] unit-test
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel new-slots sequences vectors ;
|
||||
IN: digraphs
|
||||
|
||||
TUPLE: digraph ;
|
||||
TUPLE: vertex value edges ;
|
||||
|
||||
: <digraph> ( -- digraph )
|
||||
digraph construct-empty H{ } clone over set-delegate ;
|
||||
|
||||
: <vertex> ( value -- vertex )
|
||||
V{ } clone vertex construct-boa ;
|
||||
|
||||
: add-vertex ( key value digraph -- )
|
||||
>r <vertex> swap r> set-at ;
|
||||
|
||||
: children ( key digraph -- seq )
|
||||
at edges>> ;
|
||||
|
||||
: @edges ( from to digraph -- to edges ) swapd at edges>> ;
|
||||
: add-edge ( from to digraph -- ) @edges push ;
|
||||
: delete-edge ( from to digraph -- ) @edges delete ;
|
||||
|
||||
: delete-to-edges ( to digraph -- )
|
||||
[ nip dupd edges>> delete ] assoc-each drop ;
|
||||
|
||||
: delete-vertex ( key digraph -- )
|
||||
2dup delete-at delete-to-edges ;
|
||||
|
||||
: unvisited? ( unvisited key -- ? ) swap key? ;
|
||||
: visited ( unvisited key -- ) swap delete-at ;
|
||||
|
||||
DEFER: (topological-sort)
|
||||
: visit-children ( seq unvisited key -- seq unvisited )
|
||||
over children [ (topological-sort) ] each ;
|
||||
|
||||
: (topological-sort) ( seq unvisited key -- seq unvisited )
|
||||
2dup unvisited? [
|
||||
[ visit-children ] keep 2dup visited pick push
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: topological-sort ( digraph -- seq )
|
||||
dup clone V{ } clone spin
|
||||
[ drop (topological-sort) ] assoc-each drop reverse ;
|
||||
|
||||
: topological-sorted-values ( digraph -- seq )
|
||||
dup topological-sort swap [ at value>> ] curry map ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Simple directed graph implementation for topological sorting
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel gap-buffer generic trees trees.avl-tree math sequences quotations ;
|
||||
USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ;
|
||||
IN: gap-buffer.cursortree
|
||||
|
||||
TUPLE: cursortree cursors ;
|
||||
|
||||
: <cursortree> ( seq -- cursortree )
|
||||
<gb> cursortree construct-empty tuck set-delegate <avl-tree>
|
||||
<gb> cursortree construct-empty tuck set-delegate <avl>
|
||||
over set-cursortree-cursors ;
|
||||
|
||||
GENERIC: cursortree-gb ( cursortree -- gb )
|
||||
|
|
@ -20,10 +20,11 @@ TUPLE: right-cursor ;
|
|||
|
||||
: cursor-index ( cursor -- i ) cursor-i ; inline
|
||||
|
||||
: add-cursor ( cursortree cursor -- ) dup cursor-index rot tree-insert ;
|
||||
: add-cursor ( cursortree cursor -- ) dup cursor-index rot avl-insert ;
|
||||
|
||||
: remove-cursor ( cursortree cursor -- )
|
||||
dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
|
||||
cursor-index swap delete-at ;
|
||||
! dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
|
||||
|
||||
: set-cursor-index ( index cursor -- )
|
||||
dup cursor-tree over remove-cursor tuck set-cursor-i
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
|
||||
! for a good introduction see:
|
||||
! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
|
||||
USING: kernel arrays sequences sequences.private circular math generic ;
|
||||
USING: kernel arrays sequences sequences.private circular math math.functions generic ;
|
||||
IN: gap-buffer
|
||||
|
||||
! gap-start -- the first element of the gap
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
USING: hooks kernel tools.test ;
|
||||
IN: hooks.tests
|
||||
|
||||
SYMBOL: test-hook
|
||||
test-hook reset-hook
|
||||
: add-test-hook test-hook add-hook ;
|
||||
[ ] [ test-hook call-hook ] unit-test
|
||||
[ "op called" ] [ "op" [ "op called" ] add-test-hook test-hook call-hook ] unit-test
|
||||
[ "first called" "second called" ] [
|
||||
test-hook reset-hook
|
||||
"second op" [ "second called" ] add-test-hook
|
||||
"first op" [ "first called" ] add-test-hook
|
||||
test-hook call-hook
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs digraphs kernel namespaces sequences ;
|
||||
IN: hooks
|
||||
|
||||
: hooks ( -- hooks )
|
||||
\ hooks global [ drop H{ } clone ] cache ;
|
||||
|
||||
: hook-graph ( hook -- graph )
|
||||
hooks [ drop <digraph> ] cache ;
|
||||
|
||||
: reset-hook ( hook -- )
|
||||
<digraph> swap hooks set-at ;
|
||||
|
||||
: add-hook ( key quot hook -- )
|
||||
#! hook should be a symbol. Note that symbols with the same name but
|
||||
#! different vocab are not equal
|
||||
hook-graph add-vertex ;
|
||||
|
||||
: before ( key1 key2 hook -- )
|
||||
hook-graph add-edge ;
|
||||
|
||||
: after ( key1 key2 hook -- )
|
||||
swapd before ;
|
||||
|
||||
: call-hook ( hook -- )
|
||||
hook-graph topological-sorted-values [ call ] each ;
|
||||
|
||||
|
|
@ -161,5 +161,6 @@ SYMBOL: html
|
|||
"id" "onclick" "style" "valign" "accesskey"
|
||||
"src" "language" "colspan" "onchange" "rel"
|
||||
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
|
||||
"media"
|
||||
] [ define-attribute-word ] each
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
USING: io.files io.files.tmp kernel strings tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[ t ] [ tmpdir string? ] unit-test
|
||||
[ t f ] [ ".tmp" [ dup exists? swap ] with-tmpfile exists? ] unit-test
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
USING: continuations io io.files kernel sequences strings.lib ;
|
||||
IN: io.files.tmp
|
||||
|
||||
: tmpdir ( -- dirname )
|
||||
#! ensure that a tmp dir exists and return its name
|
||||
#! I'm using a sub-directory of factor for crossplatconformity (windows doesn't have /tmp)
|
||||
"tmp" resource-path dup directory? [ dup make-directory ] unless ;
|
||||
|
||||
: touch ( filename -- )
|
||||
<file-writer> dispose ;
|
||||
|
||||
: tmpfile ( extension -- filename )
|
||||
16 random-alphanumeric-string over append
|
||||
tmpdir swap path+ dup exists? [
|
||||
drop tmpfile
|
||||
] [
|
||||
nip dup touch
|
||||
] if ;
|
||||
|
||||
: with-tmpfile ( extension quot -- )
|
||||
#! quot should have stack effect ( filename -- )
|
||||
swap tmpfile tuck swap curry swap [ delete-file ] curry [ ] cleanup ;
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel opengl arrays sequences jamshred.tunnel
|
||||
jamshred.player math.vectors ;
|
||||
IN: jamshred.game
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types colors jamshred.game jamshred.oint
|
||||
jamshred.player jamshred.tunnel kernel math math.vectors opengl
|
||||
opengl.gl opengl.glu sequences ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
USING: arrays jamshred.game jamshred.gl kernel math math.constants
|
||||
namespaces sequences timers ui ui.gadgets ui.gestures ui.render
|
||||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alarms arrays calendar jamshred.game jamshred.gl kernel math
|
||||
math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
|
||||
math.vectors ;
|
||||
IN: jamshred
|
||||
|
||||
TUPLE: jamshred-gadget jamshred last-hand-loc ;
|
||||
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
|
||||
|
||||
: <jamshred-gadget> ( jamshred -- gadget )
|
||||
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
|
||||
|
|
@ -17,13 +19,17 @@ M: jamshred-gadget pref-dim*
|
|||
M: jamshred-gadget draw-gadget* ( gadget -- )
|
||||
dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
|
||||
|
||||
M: jamshred-gadget tick ( gadget -- )
|
||||
: tick ( gadget -- )
|
||||
dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
|
||||
|
||||
M: jamshred-gadget graft* ( gadget -- )
|
||||
10 1 add-timer ;
|
||||
[
|
||||
[ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
|
||||
] keep set-jamshred-gadget-alarm ;
|
||||
|
||||
M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ;
|
||||
M: jamshred-gadget ungraft* ( gadget -- )
|
||||
[ jamshred-gadget-alarm cancel-alarm f ] keep
|
||||
set-jamshred-gadget-alarm ;
|
||||
|
||||
: jamshred-restart ( jamshred-gadget -- )
|
||||
<jamshred> swap set-jamshred-gadget-jamshred ;
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
|
||||
IN: jamshred.oint
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: colors jamshred.oint jamshred.tunnel kernel
|
||||
math math.constants sequences ;
|
||||
IN: jamshred.player
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
A simple 3d tunnel racing game
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
applications
|
||||
games
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
|
||||
IN: jamshred.tunnel.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays float-arrays kernel jamshred.oint math math.functions
|
||||
math.ranges math.vectors math.constants random sequences vectors ;
|
||||
IN: jamshred.tunnel
|
||||
|
|
|
|||
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
IN: morse
|
||||
|
||||
HELP: ch>morse
|
||||
{ $values
|
||||
{ "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
|
||||
{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
|
||||
|
||||
HELP: morse>ch
|
||||
{ $values
|
||||
{ "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
|
||||
{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
|
||||
|
||||
HELP: >morse
|
||||
{ $values
|
||||
{ "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
|
||||
{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
|
||||
{ $see-also morse> ch>morse } ;
|
||||
|
||||
HELP: morse>
|
||||
{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
|
||||
{ $description "Translates morse code into ASCII text" }
|
||||
{ $see-also >morse morse>ch } ;
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays morse strings tools.test ;
|
||||
|
||||
[ "" ] [ CHAR: \\ ch>morse ] unit-test
|
||||
[ "..." ] [ CHAR: s ch>morse ] unit-test
|
||||
[ CHAR: s ] [ "..." morse>ch ] unit-test
|
||||
[ f ] [ "..--..--.." morse>ch ] unit-test
|
||||
[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
|
||||
[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
|
||||
[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
|
||||
|
|
@ -0,0 +1,125 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs hashtables kernel lazy-lists namespaces openal
|
||||
parser-combinators promises sequences strings unicode.case ;
|
||||
IN: morse
|
||||
|
||||
<PRIVATE
|
||||
: morse-codes ( -- array )
|
||||
{
|
||||
{ CHAR: a ".-" }
|
||||
{ CHAR: b "-..." }
|
||||
{ CHAR: c "-.-." }
|
||||
{ CHAR: d "-.." }
|
||||
{ CHAR: e "." }
|
||||
{ CHAR: f "..-." }
|
||||
{ CHAR: g "--." }
|
||||
{ CHAR: h "...." }
|
||||
{ CHAR: i ".." }
|
||||
{ CHAR: j ".---" }
|
||||
{ CHAR: k "-.-" }
|
||||
{ CHAR: l ".-.." }
|
||||
{ CHAR: m "--" }
|
||||
{ CHAR: n "-." }
|
||||
{ CHAR: o "---" }
|
||||
{ CHAR: p ".--." }
|
||||
{ CHAR: q "--.-" }
|
||||
{ CHAR: r ".-." }
|
||||
{ CHAR: s "..." }
|
||||
{ CHAR: t "-" }
|
||||
{ CHAR: u "..-" }
|
||||
{ CHAR: v "...-" }
|
||||
{ CHAR: w ".--" }
|
||||
{ CHAR: x "-..-" }
|
||||
{ CHAR: y "-.--" }
|
||||
{ CHAR: z "--.." }
|
||||
{ CHAR: 1 ".----" }
|
||||
{ CHAR: 2 "..---" }
|
||||
{ CHAR: 3 "...--" }
|
||||
{ CHAR: 4 "....-" }
|
||||
{ CHAR: 5 "....." }
|
||||
{ CHAR: 6 "-...." }
|
||||
{ CHAR: 7 "--..." }
|
||||
{ CHAR: 8 "---.." }
|
||||
{ CHAR: 9 "----." }
|
||||
{ CHAR: 0 "-----" }
|
||||
{ CHAR: . ".-.-.-" }
|
||||
{ CHAR: , "--..--" }
|
||||
{ CHAR: ? "..--.." }
|
||||
{ CHAR: ' ".----." }
|
||||
{ CHAR: ! "-.-.--" }
|
||||
{ CHAR: / "-..-." }
|
||||
{ CHAR: ( "-.--." }
|
||||
{ CHAR: ) "-.--.-" }
|
||||
{ CHAR: & ".-..." }
|
||||
{ CHAR: : "---..." }
|
||||
{ CHAR: ; "-.-.-." }
|
||||
{ CHAR: = "-...- " }
|
||||
{ CHAR: + ".-.-." }
|
||||
{ CHAR: - "-....-" }
|
||||
{ CHAR: _ "..--.-" }
|
||||
{ CHAR: " ".-..-." }
|
||||
{ CHAR: $ "...-..-" }
|
||||
{ CHAR: @ ".--.-." }
|
||||
{ CHAR: \s "/" }
|
||||
} ;
|
||||
|
||||
: ch>morse-assoc ( -- assoc )
|
||||
morse-codes >hashtable ;
|
||||
|
||||
: morse>ch-assoc ( -- assoc )
|
||||
morse-codes [ reverse ] map >hashtable ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ch>morse ( ch -- str )
|
||||
ch>lower ch>morse-assoc at* swap "" ? ;
|
||||
|
||||
: morse>ch ( str -- ch )
|
||||
morse>ch-assoc at* swap f ? ;
|
||||
|
||||
: >morse ( str -- str )
|
||||
[
|
||||
[ CHAR: \s , ] [ ch>morse % ] interleave
|
||||
] "" make ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: dot ( -- ch ) CHAR: . ;
|
||||
: dash ( -- ch ) CHAR: - ;
|
||||
: char-gap ( -- ch ) CHAR: \s ;
|
||||
: word-gap ( -- ch ) CHAR: / ;
|
||||
|
||||
: =parser ( obj -- parser )
|
||||
[ = ] curry satisfy ;
|
||||
|
||||
LAZY: 'dot' ( -- parser )
|
||||
dot =parser ;
|
||||
|
||||
LAZY: 'dash' ( -- parser )
|
||||
dash =parser ;
|
||||
|
||||
LAZY: 'char-gap' ( -- parser )
|
||||
char-gap =parser ;
|
||||
|
||||
LAZY: 'word-gap' ( -- parser )
|
||||
word-gap =parser ;
|
||||
|
||||
LAZY: 'morse-char' ( -- parser )
|
||||
'dot' 'dash' <|> <+> ;
|
||||
|
||||
LAZY: 'morse-word' ( -- parser )
|
||||
'morse-char' 'char-gap' list-of ;
|
||||
|
||||
LAZY: 'morse-words' ( -- parser )
|
||||
'morse-word' 'word-gap' list-of ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: morse> ( str -- str )
|
||||
'morse-words' parse car parse-result-parsed [
|
||||
[
|
||||
>string morse>ch
|
||||
] map >string
|
||||
] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
|
||||
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces semantic-db ;
|
||||
IN: semantic-db.context
|
||||
|
||||
: create-context* ( context-name -- context-id ) create-node* ;
|
||||
: create-context ( context-name -- ) create-context* drop ;
|
||||
|
||||
: context ( -- context-id )
|
||||
\ context get ;
|
||||
|
||||
: set-context ( context-id -- )
|
||||
\ context set ;
|
||||
|
||||
: with-context ( context-id quot -- )
|
||||
>r \ context r> with-variable ;
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ;
|
||||
IN: semantic-db.hierarchy
|
||||
|
||||
TUPLE: tree id children ;
|
||||
C: <tree> tree
|
||||
|
||||
: has-parent-relation ( -- relation-id )
|
||||
"has parent" relation-id ;
|
||||
|
||||
: parent-child* ( parent child -- arc-id )
|
||||
has-parent-relation spin create-arc* ;
|
||||
|
||||
: parent-child ( parent child -- )
|
||||
parent-child* drop ;
|
||||
|
||||
: un-parent-child ( parent child -- )
|
||||
has-parent-relation spin <arc> select-tuples [ id>> delete-arc ] each ;
|
||||
|
||||
: child-arcs ( node-id -- child-arcs )
|
||||
has-parent-relation f rot <arc> select-tuples ;
|
||||
|
||||
: children ( node-id -- children )
|
||||
child-arcs [ subject>> ] map ;
|
||||
|
||||
: parent-arcs ( node-id -- parent-arcs )
|
||||
has-parent-relation swap f <arc> select-tuples ;
|
||||
|
||||
: parents ( node-id -- parents )
|
||||
parent-arcs [ object>> ] map ;
|
||||
|
||||
: get-node-hierarchy ( node-id -- tree )
|
||||
dup children [ get-node-hierarchy ] map <tree> ;
|
||||
|
||||
: (get-root-nodes) ( node-id -- root-nodes/node-id )
|
||||
dup parents dup empty? [
|
||||
drop
|
||||
] [
|
||||
nip [ (get-root-nodes) ] map
|
||||
] if ;
|
||||
|
||||
: get-root-nodes ( node-id -- root-nodes )
|
||||
(get-root-nodes) flatten ;
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: db.types kernel namespaces semantic-db semantic-db.context
|
||||
sequences.lib ;
|
||||
IN: semantic-db.relations
|
||||
|
||||
! relations:
|
||||
! - have a context in context 'semantic-db'
|
||||
|
||||
: create-relation* ( context-id relation-name -- relation-id )
|
||||
create-node* tuck has-context-relation spin create-arc ;
|
||||
|
||||
: create-relation ( context-id relation-name -- )
|
||||
create-relation* drop ;
|
||||
|
||||
: get-relation ( context-id relation-name -- relation-id/f )
|
||||
[
|
||||
":name" TEXT param ,
|
||||
":context" INTEGER param ,
|
||||
has-context-relation ":has_context" INTEGER param ,
|
||||
] { } make
|
||||
"select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context"
|
||||
single-int-results ?first ;
|
||||
|
||||
: relation-id ( relation-name -- relation-id )
|
||||
context swap [ get-relation ] [ create-relation* ] ensure2 ;
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
USING: accessors arrays db db.sqlite db.tuples kernel math namespaces
|
||||
semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations
|
||||
sequences tools.test tools.walker ;
|
||||
IN: semantic-db.tests
|
||||
|
||||
[
|
||||
create-node-table create-arc-table
|
||||
[ 1 ] [ "first node" create-node* ] unit-test
|
||||
[ 2 ] [ "second node" create-node* ] unit-test
|
||||
[ 3 ] [ "third node" create-node* ] unit-test
|
||||
[ 4 ] [ f create-node* ] unit-test
|
||||
[ 5 ] [ 1 2 3 create-arc* ] unit-test
|
||||
] with-tmp-sqlite
|
||||
|
||||
[
|
||||
init-semantic-db
|
||||
"test content" create-context* [
|
||||
[ 4 ] [ context ] unit-test
|
||||
[ 5 ] [ context "is test content" create-relation* ] unit-test
|
||||
[ 5 ] [ context "is test content" get-relation ] unit-test
|
||||
[ 5 ] [ "is test content" relation-id ] unit-test
|
||||
[ 7 ] [ "has parent" relation-id ] unit-test
|
||||
[ 7 ] [ "has parent" relation-id ] unit-test
|
||||
[ "has parent" ] [ "has parent" relation-id node-content ] unit-test
|
||||
[ "test content" ] [ context node-content ] unit-test
|
||||
] with-context
|
||||
! type-type 1array [ "type" ensure-type ] unit-test
|
||||
! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
|
||||
! [ 1 ] [ type-type select-node-of-type ] unit-test
|
||||
! [ t ] [ "content" ensure-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test
|
||||
! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test
|
||||
] with-tmp-sqlite
|
||||
|
||||
! test hierarchy
|
||||
[
|
||||
init-semantic-db
|
||||
"family tree" create-context* [
|
||||
"adam" create-node* "adam" set
|
||||
"eve" create-node* "eve" set
|
||||
"bob" create-node* "bob" set
|
||||
"fran" create-node* "fran" set
|
||||
"charlie" create-node* "charlie" set
|
||||
"gertrude" create-node* "gertrude" set
|
||||
[ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
|
||||
{ { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
|
||||
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
|
||||
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "charlie" get break get-root-nodes [ node-content ] map ] unit-test
|
||||
[ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
|
||||
] with-context
|
||||
] with-tmp-sqlite
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ;
|
||||
IN: semantic-db
|
||||
|
||||
TUPLE: node id content ;
|
||||
: <node> ( content -- node )
|
||||
node construct-empty swap >>content ;
|
||||
|
||||
: <id-node> ( id -- node )
|
||||
node construct-empty swap >>id ;
|
||||
|
||||
node "node"
|
||||
{
|
||||
{ "id" "id" +native-id+ +autoincrement+ }
|
||||
{ "content" "content" TEXT }
|
||||
} define-persistent
|
||||
|
||||
: create-node-table ( -- )
|
||||
node create-table ;
|
||||
|
||||
: delete-node ( node-id -- )
|
||||
<id-node> delete-tuple ;
|
||||
|
||||
: create-node* ( str -- node-id )
|
||||
<node> dup insert-tuple id>> ;
|
||||
|
||||
: create-node ( str -- )
|
||||
create-node* drop ;
|
||||
|
||||
: node-content ( id -- str )
|
||||
f <node> swap >>id select-tuple content>> ;
|
||||
|
||||
TUPLE: arc id relation subject object ;
|
||||
|
||||
: <arc> ( relation subject object -- arc )
|
||||
arc construct-empty swap >>object swap >>subject swap >>relation ;
|
||||
|
||||
: <id-arc> ( id -- arc )
|
||||
arc construct-empty swap >>id ;
|
||||
|
||||
: insert-arc ( arc -- )
|
||||
f <node> dup insert-tuple id>> >>id insert-tuple ;
|
||||
|
||||
: delete-arc ( arc-id -- )
|
||||
dup delete-node <id-arc> delete-tuple ;
|
||||
|
||||
: create-arc* ( relation subject object -- arc-id )
|
||||
<arc> dup insert-arc id>> ;
|
||||
|
||||
: create-arc ( relation subject object -- )
|
||||
create-arc* drop ;
|
||||
|
||||
arc "arc"
|
||||
{
|
||||
{ "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
|
||||
{ "relation" "relation" INTEGER +not-null+ }
|
||||
{ "subject" "subject" INTEGER +not-null+ }
|
||||
{ "object" "object" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: create-arc-table ( -- )
|
||||
arc create-table ;
|
||||
|
||||
: create-bootstrap-nodes ( -- )
|
||||
"semantic-db" create-node
|
||||
"has context" create-node ;
|
||||
|
||||
: semantic-db-context 1 ;
|
||||
: has-context-relation 2 ;
|
||||
|
||||
: create-bootstrap-arcs ( -- )
|
||||
has-context-relation has-context-relation semantic-db-context create-arc ;
|
||||
|
||||
: init-semantic-db ( -- )
|
||||
create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
|
||||
|
||||
: param ( value key type -- param )
|
||||
swapd 3array ;
|
||||
|
||||
: single-int-results ( bindings sql -- array )
|
||||
f f <simple-statement> [ do-bound-query ] with-disposal
|
||||
[ first string>number ] map ;
|
||||
|
||||
: ensure2 ( x y quot1 quot2 -- z )
|
||||
#! quot1 ( x y -- z/f ) finds an existing z
|
||||
#! quot2 ( x y -- z ) creates a new z if quot1 returns f
|
||||
>r >r 2dup r> call [ 2nip ] r> if* ;
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays db db.types kernel semantic-db sequences sequences.lib ;
|
||||
IN: semantic-db.type
|
||||
|
||||
! types:
|
||||
! - have type 'type' in context 'semantic-db'
|
||||
! - have a context in context 'semantic-db'
|
||||
|
||||
: assign-type ( type nid -- arc-id )
|
||||
has-type-relation spin arc-id ;
|
||||
|
||||
: create-node-of-type ( type content -- node-id )
|
||||
node-id [ assign-type drop ] keep ;
|
||||
|
||||
: select-nodes-of-type ( type -- node-ids )
|
||||
":type" INTEGER param
|
||||
has-type-relation ":has_type" INTEGER param 2array
|
||||
"select a.subject from arc a where a.relation = :has_type and a.object = :type"
|
||||
single-int-results ;
|
||||
|
||||
: select-node-of-type ( type -- node-id )
|
||||
select-nodes-of-type ?first ;
|
||||
|
||||
: select-nodes-of-type-with-content ( type content -- node-ids )
|
||||
! find nodes with the given content that are the subjects of arcs with:
|
||||
! relation = has-type-relation
|
||||
! object = type
|
||||
":name" TEXT param
|
||||
swap ":type" INTEGER param
|
||||
has-type-relation ":has_type" INTEGER param 3array
|
||||
"select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type"
|
||||
single-int-results ;
|
||||
|
||||
: select-node-of-type-with-content ( type content -- node-id/f )
|
||||
select-nodes-of-type-with-content ?first ;
|
||||
|
||||
: ensure-node-of-type ( type content -- node-id )
|
||||
[ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ;
|
||||
! 2dup select-node-of-type-with-content [ 2nip ] [ create-node-of-type ] if* ;
|
||||
|
||||
|
||||
: ensure-type ( type -- node-id )
|
||||
dup "type" = [
|
||||
drop type-type
|
||||
] [
|
||||
type-type swap ensure-node-of-type
|
||||
] if ;
|
||||
|
|
@ -0,0 +1,156 @@
|
|||
! Copyright (C) 2005 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! An interface to the sqlite database. Tested against sqlite v3.0.8.
|
||||
!
|
||||
! Not all functions have been wrapped yet. Only those directly involving
|
||||
! executing SQL calls and obtaining results.
|
||||
!
|
||||
IN: sqlite
|
||||
USING: alien compiler io.files.tmp kernel math namespaces sequences strings
|
||||
sqlite.lib alien.c-types continuations ;
|
||||
|
||||
TUPLE: sqlite-error n message ;
|
||||
SYMBOL: db
|
||||
|
||||
! High level sqlite routines
|
||||
: sqlite-check-result ( result -- )
|
||||
#! Check the result from a sqlite call is ok. If it is
|
||||
#! return, otherwise throw an error.
|
||||
dup SQLITE_OK = [
|
||||
drop
|
||||
] [
|
||||
dup sqlite-error-messages nth
|
||||
\ sqlite-error construct-boa throw
|
||||
] if ;
|
||||
|
||||
: sqlite-open ( filename -- db )
|
||||
#! Open the database referenced by the filename and return
|
||||
#! a handle to that database. An error is thrown if the database
|
||||
#! failed to open.
|
||||
"void*" <c-object> [ sqlite3_open sqlite-check-result ] keep *void* ;
|
||||
|
||||
: sqlite-close ( db -- )
|
||||
#! Close the given database
|
||||
sqlite3_close sqlite-check-result ;
|
||||
|
||||
: sqlite-last-insert-rowid ( db -- rowid )
|
||||
#! Return the rowid of the last insert
|
||||
sqlite3_last_insert_rowid ;
|
||||
|
||||
: sqlite-prepare ( db sql -- statement )
|
||||
#! Prepare a SQL statement. Returns the statement which
|
||||
#! can have values bound to parameters or simply executed.
|
||||
#! TODO: Support multiple statements in the SQL string.
|
||||
dup length "void*" <c-object> "void*" <c-object>
|
||||
[ sqlite3_prepare sqlite-check-result ] 2keep
|
||||
drop *void* ;
|
||||
|
||||
: sqlite-bind-text ( statement index text -- )
|
||||
#! Bind the text to the parameterized value in the statement.
|
||||
dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-int ( statement index int -- )
|
||||
sqlite3_bind_int sqlite-check-result ;
|
||||
|
||||
GENERIC: sqlite-bind ( statement index obj -- )
|
||||
|
||||
M: object sqlite-bind ( statement index obj -- )
|
||||
sqlite-bind-text ;
|
||||
|
||||
M: integer sqlite-bind ( statement index int -- )
|
||||
sqlite-bind-int ;
|
||||
|
||||
: sqlite-bind-parameter-index ( statement name -- index )
|
||||
sqlite3_bind_parameter_index ;
|
||||
|
||||
: sqlite-bind-text-by-name ( statement name text -- )
|
||||
>r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
|
||||
|
||||
: sqlite-bind-by-name ( statement name obj -- )
|
||||
>r dupd sqlite-bind-parameter-index r> sqlite-bind ;
|
||||
|
||||
GENERIC# sqlite-bind-by-name-or-index 1 ( statement key val -- )
|
||||
|
||||
M: object sqlite-bind-by-name-or-index ( statement object val -- )
|
||||
sqlite-bind-by-name ;
|
||||
|
||||
M: integer sqlite-bind-by-name-or-index ( statement integer val -- )
|
||||
sqlite-bind ;
|
||||
|
||||
: sqlite-finalize ( statement -- )
|
||||
#! Clean up all resources related to a statement. Once called
|
||||
#! the statement cannot be used. All statements must be finalized
|
||||
#! before closing the database.
|
||||
sqlite3_finalize sqlite-check-result ;
|
||||
|
||||
: sqlite-reset ( statement -- )
|
||||
#! Reset a statement so it can be called again, possibly with
|
||||
#! different parameters.
|
||||
sqlite3_reset sqlite-check-result ;
|
||||
|
||||
: column-count ( statement -- int )
|
||||
#! Given a prepared statement, return the number of
|
||||
#! columns in each row of the result set of that statement.
|
||||
sqlite3_column_count ;
|
||||
|
||||
: column-text ( statement index -- string )
|
||||
#! Return the value of the given column, indexed
|
||||
#! from zero, as a string.
|
||||
sqlite3_column_text ;
|
||||
|
||||
: column-int ( statement index -- int )
|
||||
sqlite3_column_int ;
|
||||
|
||||
: step-complete? ( step-result -- bool )
|
||||
#! Return true if the result of a sqlite3_step is
|
||||
#! such that the iteration has completed (ie. it is
|
||||
#! SQLITE_DONE). Throw an error if an error occurs.
|
||||
dup SQLITE_ROW = [
|
||||
drop f
|
||||
] [
|
||||
dup SQLITE_DONE = [
|
||||
drop t
|
||||
] [
|
||||
sqlite-check-result t
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: sqlite-each ( statement quot -- )
|
||||
#! Execute the SQL statement, and call the quotation for
|
||||
#! each row returned from executing the statement with the
|
||||
#! statement on the top of the stack.
|
||||
over sqlite3_step step-complete? [
|
||||
2drop
|
||||
] [
|
||||
[ call ] 2keep sqlite-each
|
||||
] if ; inline
|
||||
|
||||
! For comparison, here is the linrec implementation of sqlite-each
|
||||
! [ drop sqlite3_step step-complete? ]
|
||||
! [ 2drop ]
|
||||
! [ 2dup 2slip ]
|
||||
! [ ] linrec ;
|
||||
|
||||
DEFER: (sqlite-map)
|
||||
|
||||
: (sqlite-map) ( statement quot seq -- )
|
||||
pick sqlite3_step step-complete? [
|
||||
2nip
|
||||
] [
|
||||
>r 2dup call r> swap add (sqlite-map)
|
||||
] if ;
|
||||
|
||||
: sqlite-map ( statement quot -- seq )
|
||||
{ } (sqlite-map) ;
|
||||
|
||||
: with-sqlite ( path quot -- )
|
||||
[
|
||||
>r sqlite-open db set r>
|
||||
[ db get sqlite-close ] [ ] cleanup
|
||||
] with-scope ;
|
||||
|
||||
: with-tmp-db ( quot -- )
|
||||
".db" [
|
||||
swap with-sqlite
|
||||
] with-tmpfile ;
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
USING: kernel sequences strings.lib tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test
|
||||
[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
|
||||
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
|
||||
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
|
||||
[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
USING: math arrays sequences kernel random splitting strings unicode.case ;
|
||||
IN: strings.lib
|
||||
|
||||
: char>digit ( c -- i ) 48 - ;
|
||||
|
||||
: string>digits ( s -- seq ) [ char>digit ] { } map-as ;
|
||||
|
||||
: >Upper ( str -- str )
|
||||
dup empty? [
|
||||
unclip ch>upper 1string swap append
|
||||
] unless ;
|
||||
|
||||
: >Upper-dashes ( str -- str )
|
||||
"-" split [ >Upper ] map "-" join ;
|
||||
|
||||
: lower-alpha-chars ( -- seq )
|
||||
26 [ CHAR: a + ] map ;
|
||||
|
||||
: upper-alpha-chars ( -- seq )
|
||||
26 [ CHAR: A + ] map ;
|
||||
|
||||
: numeric-chars ( -- seq )
|
||||
10 [ CHAR: 0 + ] map ;
|
||||
|
||||
: alpha-chars ( -- seq )
|
||||
lower-alpha-chars upper-alpha-chars append ;
|
||||
|
||||
: alphanumeric-chars ( -- seq )
|
||||
alpha-chars numeric-chars append ;
|
||||
|
||||
: random-alpha-char ( -- ch )
|
||||
alpha-chars random ;
|
||||
|
||||
: random-alphanumeric-char ( -- ch )
|
||||
alphanumeric-chars random ;
|
||||
|
||||
: random-alphanumeric-string ( length -- str )
|
||||
[ drop random-alphanumeric-char ] map "" like ;
|
||||
|
||||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2006, 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel ui.gadgets ui.gadgets.labels ui.gadgets.worlds
|
||||
ui.gadgets.status-bar ui.gestures ui.render ui tetris.game
|
||||
tetris.gl sequences arrays math math.parser namespaces timers ;
|
||||
USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels
|
||||
ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui
|
||||
tetris.game tetris.gl sequences system math math.parser namespaces ;
|
||||
IN: tetris
|
||||
|
||||
TUPLE: tetris-gadget tetris ;
|
||||
TUPLE: tetris-gadget tetris alarm ;
|
||||
|
||||
: <tetris-gadget> ( tetris -- gadget )
|
||||
tetris-gadget construct-gadget
|
||||
|
|
@ -41,14 +41,15 @@ tetris-gadget H{
|
|||
{ T{ key-down f f "n" } [ new-tetris ] }
|
||||
} set-gestures
|
||||
|
||||
M: tetris-gadget tick ( object -- )
|
||||
: tick ( gadget -- )
|
||||
dup tetris-gadget-tetris maybe-update relayout-1 ;
|
||||
|
||||
M: tetris-gadget graft* ( gadget -- )
|
||||
100 1 add-timer ;
|
||||
dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm
|
||||
swap set-tetris-gadget-alarm ;
|
||||
|
||||
M: tetris-gadget ungraft* ( gadget -- )
|
||||
remove-timer ;
|
||||
[ tetris-gadget-alarm cancel-alarm f ] keep set-tetris-gadget-alarm ;
|
||||
|
||||
: tetris-window ( -- )
|
||||
[
|
||||
|
|
|
|||
Loading…
Reference in New Issue