: bit-set-like ( set bit-set -- bit-set' )
! Throws an error if there are keys that can't be put
! in the bit set
- over bit-set? [ 2dup [ table>> length ] bi@ = ] [ f ] if
+ over bit-set? [ 2dup [ table>> length ] same? ] [ f ] if
[ drop ] [
[ members ] dip table>> length <bit-set>
[ [ adjoin ] curry each ] keep
GENERIC: (eql?) ( obj1 obj2 -- ? )
: eql? ( obj1 obj2 -- ? )
- { [ [ class-of ] bi@ = ] [ (eql?) ] } 2&& ;
+ { [ [ class-of ] same? ] [ (eql?) ] } 2&& ;
M: fixnum (eql?) eq? ;
M: float (eql?) fp-bitwise= ;
-M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
+M: sequence (eql?) 2dup [ length ] same? [ [ eql? ] 2all? ] [ 2drop f ] if ;
M: object (eql?) = ;
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"
- "now gmt >local-time [ gmt-offset>> ] bi@ = ."
+ "now gmt >local-time [ gmt-offset>> ] same? ."
"t"
}
} ;
[ >gmt tuple-slots ] compare ;
: same-day? ( ts1 ts2 -- ? )
- [ >gmt >date< <date> ] bi@ = ;
+ [ >gmt >date< <date> ] same? ;
: (time-) ( timestamp timestamp -- n )
[ >gmt ] bi@
:: nth-day-this-month ( timestamp n day -- new-timestamp )
timestamp beginning-of-month day day-this-week
- dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless
+ dup timestamp [ month>> ] same? [ 1 weeks time+ ] unless
n 1 - [ weeks time+ ] unless-zero ;
: last-day-this-month ( timestamp day -- new-timestamp )
{\r
MONTH " " DD " "\r
[\r
- dup now [ year>> ] bi@ =\r
+ dup now [ year>> ] same?\r
[ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if\r
]\r
} formatted\r
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-1 malloc-struct &free 5 >>x
- [ hashcode ] bi@ =
+ [ hashcode ] same?
] with-destructors
] unit-test
M: struct equal?
over struct? [
- 2dup [ class-of ] bi@ = [
+ 2dup [ class-of ] same? [
2dup [ >c-ptr ] both?
[ [ >c-ptr ] [ binary-object ] bi* memory= ]
[ [ >c-ptr not ] both? ]
H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 5 } }
H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 6 } }
} [ >cf &CFRelease ] [ >cf &CFRelease ] bi
- [ plist> ] bi@ =
+ [ plist> ] same?
] unit-test
[ t ] [
{ "DeviceUsagePage" 1 }
[ >cf &CFRelease ] [ >cf &CFRelease ] bi
- [ plist> ] bi@ =
+ [ plist> ] same?
] unit-test
[ V{ "DeviceUsagePage" "Yes" } ] [
: useless-compare? ( insn -- ? )
{
[ cc>> cc= eq? ]
- [ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] bi@ = not ]
+ [ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] same? not ]
} 1&& ; inline
M: ##compare analyze-aliases
children parent
registers parent-index ;
-M: node equal? over node? [ [ number>> ] bi@ = ] [ 2drop f ] if ;
+M: node equal? over node? [ [ number>> ] same? ] [ 2drop f ] if ;
M: node hashcode* nip number>> ;
: verify-children ( trees -- trees )
dup [ flatten-tree ] map concat
nodes get
- { [ [ length ] bi@ = ] [ set= ] } 2&&
+ { [ [ length ] same? ] [ set= ] } 2&&
[ nodes get node-missing-children ] unless ;
: verify-trees ( trees -- trees )
M: location equal?
over location? [
- { [ [ reg>> ] bi@ = ] [ [ reg-class>> ] bi@ = ] } 2&&
+ { [ [ reg>> ] same? ] [ [ reg-class>> ] same? ] } 2&&
] [ 2drop f ] if ;
M: location hashcode*
M: fixnum eql? eq? ;
M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
-M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
+M: float eql? over float? [ [ double>bits ] same? ] [ 2drop f ] if ;
M: complex eql? over complex? [ = ] [ 2drop f ] if ;
! Value info represents a set of objects. Don't mutate value infos
{ [ dup not ] [ drop ] }
{ [ over not ] [ nip ] }
[
- 2dup [ length ] bi@ =
+ 2dup [ length ] same?
[ [ intersect-slot ] 2map ] [ 2drop f ] if
]
} cond ;
: union-slots ( info1 info2 -- slots )
[ slots>> ] bi@
- 2dup [ length ] bi@ =
+ 2dup [ length ] same?
[ [ union-slot ] 2map ] [ 2drop f ] if ;
: (value-info-union) ( info1 info2 -- info )
tag>> \ reply boa ;\r
\r
: synchronous-reply? ( response synchronous -- ? )\r
- over reply? [ [ tag>> ] bi@ = ] [ 2drop f ] if ;\r
+ over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;\r
\r
ERROR: cannot-send-synchronous-to-self message thread ;\r
\r
M: dlist equal?
over dlist? [
[ front>> ] bi@
- [ 2dup { [ and ] [ [ obj>> ] bi@ = ] } 2&& ]
+ [ 2dup { [ and ] [ [ obj>> ] same? ] } 2&& ]
[ [ next>> ] bi@ ] while
or not
] [
! (This word is called by the 'update-user' method.)
: check-update ( old new -- ? )
[
- 2dup [ "email" swap at ] bi@ = not [
+ 2dup [ "email" swap at ] same? not [
[ "email" swap at ] bi@
[ drop "email" reservation-id unreserve-from-id ]
[ nip "email" reserve ]
2bi
] [ 2drop t ] if
] [
- 2dup [ "username" swap at ] bi@ = not [
+ 2dup [ "username" swap at ] same? not [
[ "username" swap at ] bi@
[ drop "username" reservation-id unreserve-from-id ]
[ nip "username" reserve ]
[ host>> ]
[ port>> remap-port ]
tri 3array
- ] bi@ =
+ ] same?
] when ;
: cookie-client-state ( key request -- value/f )
underlying>> >alist [ [ first underlying>> ] [ second ] bi 2array ] map ;
M: wrapped-hashtable equal?
- over wrapped-hashtable? [ [ underlying>> ] bi@ = ] [ 2drop f ] if ;
+ over wrapped-hashtable? [ [ underlying>> ] same? ] [ 2drop f ] if ;
INSTANCE: wrapped-hashtable assoc
"date: Wed, 12 Oct 2011 18:57:49 GMT"
"server: Factor http.server"
} [ "\n" join ] [ "\r\n" join ] bi
- [ [ read-response ] with-string-reader ] bi@ =
+ [ [ read-response ] with-string-reader ] same?
] unit-test
"host: 127.0.0.1:55532"
"user-agent: Factor http.client"
} [ "\n" join ] [ "\r\n" join ] bi
- [ [ read-request ] with-string-reader ] bi@ =
+ [ [ read-request ] with-string-reader ] same?
] unit-test
! RFC 2616: Section 4.1
\ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
: assure-same-class ( obj1 obj2 -- )
- [ class-of ] bi@ = assure ; inline
+ [ class-of ] same? assure ; inline
\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
[
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
current-temporary-directory get [ ] find-all-files
- ] cleanup-unique-directory [ natural-sort ] bi@ =
+ ] cleanup-unique-directory [ natural-sort ] same?
] unit-test
[ f ] [
M: malloc-ptr hashcode* value>> hashcode* ;
M: malloc-ptr equal?
- over malloc-ptr? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
+ over malloc-ptr? [ [ value>> ] same? ] [ 2drop f ] if ;
: <malloc-ptr> ( value -- malloc-ptr )
malloc-ptr new swap >>value ;
{ [ 2dup = ] [ 2drop t ] }
{ [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
{ [ 2dup [ sequence? ] both? ] [
- 2dup [ length ] bi@ =
+ 2dup [ length ] same?
[ [ (match) ] 2all? ] [ 2drop f ] if ] }
{ [ 2dup [ tuple? ] both? ]
[ [ tuple>array ] bi@ [ (match) ] 2all? ] }
TUPLE: parse-error position messages ;
TUPLE: parser peg compiled id ;
-M: parser equal? { [ [ class-of ] bi@ = ] [ [ id>> ] bi@ = ] } 2&& ;
+M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ;
M: parser hashcode* id>> hashcode* ;
C: <parse-result> parse-result
bi ;
: ok? ( assoc1 assoc2 -- ? )
- [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
+ [ assoc= ] [ [ assoc-size ] same? ] 2bi and ;
: test-persistent-hashtables-1 ( n -- ? )
random-assocs ok? ;
[ length 0 <array> ] [ [ length ] map ] bi ;
: end-product-iter? ( ns lengths -- ? )
- [ last ] bi@ = ;
+ [ last ] same? ;
PRIVATE>
[ { { 2 2 } { 3 3 3 3 } { 4 } { 5 } } ]
[
- { 2 2 3 3 3 3 4 5 }
- [ [ odd? ] bi@ = ] slice monotonic-slice
+ { 2 2 3 3 3 3 4 5 }
+ [ [ odd? ] same? ] slice monotonic-slice
[ >array ] map
] unit-test
{ { 1 1 1 } { 2 2 2 2 } { 3 3 } }
] [
{ 1 1 1 2 2 2 2 3 3 }
- [ [ odd? ] bi@ = ] slice monotonic-slice
+ [ [ odd? ] same? ] slice monotonic-slice
[ >array ] map
] unit-test
: check-call-site-stack ( label -- )
[ ] [ call-site-stack ] [ trimmed-enter-out ] tri
- [ dup undeclared-known [ [ undeclared-known ] bi@ = ] [ 2drop t ] if ] 2all?
+ [ dup undeclared-known [ [ undeclared-known ] same? ] [ 2drop t ] if ] 2all?
[ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
: check-call ( label -- )
per-word-samples [ f 0 <profile-node> ] assoc-map ;
: redundant-flat-node? ( child-node root-node -- ? )
- [ total-time>> ] bi@ = ;
+ [ total-time>> ] same? ;
: trim-flat ( root-node -- root-node' )
dup '[ [ nip _ redundant-flat-node? not ] assoc-filter ] change-children ;
M: windows-ui-backend (fullscreen?) ( world -- ? )
handle>> hWnd>>
[ hwnd>RECT ] [ fullscreen-RECT ] bi
- [ get-RECT-dimensions 2array 2nip ] bi@ = ;
+ [ get-RECT-dimensions 2array 2nip ] same? ;
M: windows-ui-backend ui-backend-available?
t ;
align-left ; inline
M: radio-control model-changed
- 2dup [ value>> ] bi@ = >>selected? relayout-1 drop ;
+ 2dup [ value>> ] same? >>selected? relayout-1 drop ;
:: <radio-controls> ( model assoc parent quot: ( value model label -- gadget ) -- parent )
parent assoc [ model swap quot call add-gadget ] assoc-each ; inline
[\r
[ collation-key ] dip\r
[ [ 0 = not ] trim-tail but-last ] times\r
- ] curry bi@ = ;\r
+ ] curry same? ;\r
PRIVATE>\r
\r
: primary= ( str1 str2 -- ? )\r
f OleInitialize check-ole32-error ;
: guid= ( a b -- ? )
- [ 16 memory>byte-array ] bi@ = ;
+ [ 16 memory>byte-array ] same? ;
CONSTANT: GUID-STRING-LENGTH
$[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
[ ?first ] [ ?second ] bi ;
: split-words ( seq -- half-elements )
- [ [ break?>> ] bi@ = ] monotonic-split ;
+ [ [ break?>> ] same? ] monotonic-split ;
: ?first-break ( seq -- newseq f/element )
dup first first break?>>
2dup [ expired? ] either? [
[ expired? ] both?
] [
- [ alien-address ] bi@ =
+ [ alien-address ] same?
] if
] [
2drop f
{ [ 2dup [ bivariable-effect? ] either? ] [ f ] }
{ [ 2dup [ variable-effect? ] [ variable-effect? not ] bi* and ] [ f ] }
{ [ 2dup [ in>> length ] bi@ > ] [ f ] }
- { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
+ { [ 2dup [ effect-height ] same? not ] [ f ] }
[ t ]
} cond 2nip ; inline
: effect= ( effect1 effect2 -- ? )
- [ [ in>> length ] bi@ = ]
- [ [ out>> length ] bi@ = ]
- [ [ terminated?>> ] bi@ = ]
+ [ [ in>> length ] same? ]
+ [ [ out>> length ] same? ]
+ [ [ terminated?>> ] same? ]
2tri and and ;
GENERIC: effect>string ( obj -- str )
"method-generic" word-prop "declared-effect" word-prop ;
: method-effect= ( method-effect generic-effect -- ? )
- [ [ in>> length ] bi@ = ]
+ [ [ in>> length ] same? ]
[
over terminated?>>
- [ 2drop t ] [ [ out>> length ] bi@ = ] if
+ [ 2drop t ] [ [ out>> length ] same? ] if
] 2bi and ;
ERROR: bad-method-effect ;
! Testing ~ special pathname
[ t ] [ os windows? "~\\" "~/" ? absolute-path home = ] unit-test
-[ t ] [ "~/" home [ normalize-path ] bi@ = ] unit-test
+[ t ] [ "~/" home [ normalize-path ] same? ] unit-test
[ t ] [ "~" absolute-path home = ] unit-test
-[ t ] [ "~" home [ normalize-path ] bi@ = ] unit-test
+[ t ] [ "~" home [ normalize-path ] same? ] unit-test
-[ t ] [ "~" home [ "foo" append-path ] bi@ [ normalize-path ] bi@ = ] unit-test
-[ t ] [ os windows? "~\\~/" "~/~/" ? "~" "~" append-path [ path-components ] bi@ = ] unit-test
+[ t ] [ "~" home [ "foo" append-path ] bi@ [ normalize-path ] same? ] unit-test
+[ t ] [ os windows? "~\\~/" "~/~/" ? "~" "~" append-path [ path-components ] same? ] unit-test
simple-lexer-dump ;
: parsing-word-lexer-dump ( error parsing-word -- )
- 2dup [ line>> ] bi@ =
+ 2dup [ line>> ] same?
[ drop simple-lexer-dump ]
[ (parsing-word-lexer-dump) ] if ;
UNION: number real complex ;
-: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline
+: fp-bitwise= ( x y -- ? ) [ double>bits ] same? ; inline
GENERIC: fp-special? ( x -- ? )
GENERIC: fp-nan? ( x -- ? )
M: compose call uncompose [ call ] dip call ;
M: wrapper equal?
- over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
+ over wrapper? [ [ wrapped>> ] same? ] [ 2drop f ] if ;
UNION: callable quotation curry compose ;
[ "xx" ] [ "blahxx" 2 tail* ] unit-test
[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test
-[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] same? ] unit-test
[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test
-[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] same? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
-[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] bi@ = ] unit-test
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] same? ] unit-test
[ -10 "hi" "bye" copy ] must-fail
[ 10 "hi" "bye" copy ] must-fail
[ 2nth-unsafe <=> ] [ [ length ] compare nip ] if ;
: sequence= ( seq1 seq2 -- ? )
- 2dup [ length ] bi@ =
+ 2dup [ length ] same?
[ mismatch not ] [ 2drop f ] if ; inline
ERROR: assert-sequence got expected ;
[
scale-decimals
{
- [ [ mantissa>> ] bi@ = ]
- [ [ exponent>> ] bi@ = ]
+ [ [ mantissa>> ] same? ]
+ [ [ exponent>> ] same? ]
} 2&&
]
} 2&& ;
"More generally, the following should always be the case:"
{ $example
"USING: accessors graphviz kernel prettyprint ;"
- "<anon> <anon> [ id>> ] bi@ = ."
+ "<anon> <anon> [ id>> ] same? ."
"f"
}
}
: atlas-image-format ( image-placements -- component-order component-type upside-down? )
[ image>> ] map dup unclip '[ _
- [ [ component-order>> ] bi@ = ]
- [ [ component-type>> ] bi@ = ]
- [ [ upside-down?>> ] bi@ = ] 2tri and and
+ [ [ component-order>> ] same? ]
+ [ [ component-type>> ] same? ]
+ [ [ upside-down?>> ] same? ] 2tri and and
] all?
[ first [ component-order>> ] [ component-type>> ] [ upside-down?>> ] tri ]
[ atlas-image-formats-dont-match ] if ; inline
: top-directory? ( path -- ? )
dup ".." append-path [ link-status ] bi@
- [ [ st_dev>> ] bi@ = not ] [ [ st_ino>> ] bi@ = ] 2bi or ;
+ [ [ st_dev>> ] same? not ] [ [ st_ino>> ] same? ] 2bi or ;
: top-directory ( path -- path' )
[ dup top-directory? not ] [ ".." append-path ] while ;
[ T{ struct f f { float TYPE: i32 (i32)* ; } t } ]
[ TYPE: < { float, i32 (i32)* } > ; ] unit-test
-[ t ] [ TYPE: i32 ; TYPE: i32 ; [ >tref ] bi@ = ] unit-test
-[ t ] [ TYPE: i32 * ; TYPE: i32 * ; [ >tref ] bi@ = ] unit-test
+[ t ] [ TYPE: i32 ; TYPE: i32 ; [ >tref ] same? ] unit-test
+[ t ] [ TYPE: i32 * ; TYPE: i32 * ; [ >tref ] same? ] unit-test
[ TYPE: i32 ; ] [ TYPE: i32 ; >tref tref> ] unit-test
[ TYPE: float ; ] [ TYPE: float ; >tref tref> ] unit-test
[ TYPE: < { i32, i32 } > ; ] [ TYPE: < { i32, i32 } > ; >tref tref> ] unit-test
[ TYPE: i32 ( i32 ) ; ] [ TYPE: i32 ( i32 ) ; >tref tref> ] unit-test
[ TYPE: \1* ; ] [ TYPE: \1* ; >tref tref> ] unit-test
-[ TYPE: { i32, \2* } ; ] [ TYPE: { i32, \2* } ; >tref tref> ] unit-test
\ No newline at end of file
+[ TYPE: { i32, \2* } ; ] [ TYPE: { i32, \2* } ; >tref tref> ] unit-test
M: blas-vector-base equal?
{
- [ [ length ] bi@ = ]
+ [ [ length ] same? ]
[ [ = ] 2all? ]
} 2&& ;
: mod' ( x y -- n )
[ mod ] keep over zero? [ drop ] [
- 2dup [ sgn ] bi@ = [ drop ] [ + ] if
+ 2dup [ sgn ] same? [ drop ] [ + ] if
] if ;
PRIVATE>
drop v- [ abs ] [ + ] map-reduce ;
M: maze cost
- drop 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
+ drop 2dup [ first ] same? [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
: test1 ( to -- path considered )
{ 1 1 } swap maze new [ find-path ] [ considered ] bi ;
[ propagate dup ] map nip reverse swap suffix ;
: permutations? ( n m -- ? )
- [ count-digits ] bi@ = ;
+ [ count-digits ] same? ;
: sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
: quadtree-size ( tree -- count )
dup leaf?>> [ leaf-size ] [ node-size ] if ;
-: leaf= ( a b -- ? ) [ [ point>> ] [ value>> ] bi 2array ] bi@ = ;
+: leaf= ( a b -- ? ) [ [ point>> ] [ value>> ] bi 2array ] same? ;
-: node= ( a b -- ? ) [ {quadrants} ] bi@ = ;
+: node= ( a b -- ? ) [ {quadrants} ] same? ;
: (tree=) ( a b -- ? ) dup leaf?>> [ leaf= ] [ node= ] if ;
: tree= ( a b -- ? )
- 2dup [ leaf?>> ] bi@ = [ (tree=) ] [ 2drop f ] if ;
+ 2dup [ leaf?>> ] same? [ (tree=) ] [ 2drop f ] if ;
PRIVATE>
{ { } } [ "ABC" [ ] { } trim-as ] unit-test
{ "ABC" } [ { 32 65 66 67 32 } [ blank? ] "" trim-as ] unit-test
-{ t } [ "ABC" dup [ blank? ] ?trim [ identity-hashcode ] bi@ = ] unit-test
+{ t } [ "ABC" dup [ blank? ] ?trim [ identity-hashcode ] same? ] unit-test
{ "ABC" } [ " ABC " [ blank? ] ?trim ] unit-test
[ 10 /i ] map ;
: bitmap= ( bitmap1 bitmap2 -- ? )
- [ bitmap>> twiddle ] bi@ = ;
+ [ bitmap>> twiddle ] same? ;
: check-rendering ( gadget -- )
screenshot
[ top>> ] [ bot>> ] bi ;
: check-dimensions ( d d -- )
- [ dimensions 2array ] bi@ =
+ [ dimensions 2array ] same?
[ dimensions-not-equal ] unless ;
: 2values ( dim dim -- val val ) [ value>> ] bi@ ;
\r
: get-silhouette ( solid -- silhouette ) \r
silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
+: solid= ( solid solid -- ? ) [ corners>> ] same? ;\r
\r
: space-apply ( space m quot -- space ) \r
curry [ map ] curry [ dup solids>> ] dip\r
{ 2 1 } [ add ] must-infer-as
[ 5 ] [ 2 3 add ] unit-test
-[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
+[ t ] [ "double" "bigfloat" [ resolve-typedef ] same? ] unit-test
{ 1 1 } [ smaller ] must-infer-as
[ 1.0 ] [ 10 smaller ] unit-test
: {name-type-class} ( obj -- array )
[ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
-: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
+: rr=query? ( obj obj -- ? ) [ {name-type-class} ] same? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: node-content ( node -- content )
dup content>> [ nip ] [ select-tuple content>> ] if* ;
-: node= ( node node -- ? ) [ id>> ] bi@ = ;
+: node= ( node node -- ? ) [ id>> ] same? ;
! TODO: get rid of arc id and write our own sql
TUPLE: arc id subject object relation ;
: row ( index -- row ) 1 + 9 / ceiling ;
: col ( index -- col ) 9 mod 1 + ;
: sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
-: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
+: near ( a pos -- ? ) { [ [ row ] same? ] [ [ col ] same? ] [ [ sq ] same? ] } 2|| ;
: nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
:: solutions ( puzzle random? -- solutions )
projects / factor.git / commitdiff