[Desktop Entry]
Type=Application
Name=sACNView 2
Exec=/opt/sacnview/sACNView2.AppImage
Icon=sacnview
Comment=Streaming ACN Viewer mark2
Terminal=false
Categories=Network;

Fix categories for Linux Installer


[Desktop Entry]
Name=Restnotifier
GenericName=Reminds you to rest
Comment=Reminds you to rest
GenericName[ru]=Напоминает отдохнуть
Comment[ru]=Напоминает отдохнуть
Exec=restnotifier
Icon=restnotifier.png
Terminal=false
Type=Application
Categories=Qt;Utilities;

Fix icon name and category in .desktop

[Desktop Entry]
Name=Restnotifier
GenericName=Reminds you to rest
Comment=Reminds you to rest
GenericName[ru]=Напоминает отдохнуть
Comment[ru]=Напоминает отдохнуть
Exec=restnotifier
Icon=restnotifier
Terminal=false
Type=Application
Categories=Qt;Utility;


[Desktop Entry]
Name=Hyperbox
Type=Application
Categories=Utility;System;
Comment=Manage your virtual infrastructure

Make the Client shortcut compatible with Ubuntu 16.04

[Desktop Entry]
Version=1.0
Name=Hyperbox
Type=Application
Categories=Utility;System;
Comment=Manage your virtual infrastructure


[Desktop Entry]
Name=XHydra
GenericName=Hydra very fast network log-on cracker
Comment=GUI frontend for Hydra network log-on cracker
Version=1.0
Exec=xhydra
Icon=xhydra
Terminal=false
Type=Application
Categories=System;Security;GTK;


[Desktop Entry]
Encoding=UTF-8
Type=Application
Name=SageTV Client 6.5.8
Comment=Client/Placeshifter for SageTV 6.5.8
Exec=/opt/sagetv/client/sageclient.sh
TryExec=/opt/sagetv/client/sageclient.sh
Terminal=false
Categories=Applications;AudioVideo
Icon=SageIcon64.png

Remove hard-coded SageTV versions in the Ubuntu desktop shortcut file.

[Desktop Entry]
Encoding=UTF-8
Type=Application
Name=SageTV Client MAJOR_VERSION.MINOR_VERSION.MICRO_VERSION
Comment=Client/Placeshifter for SageTV MAJOR_VERSION.MINOR_VERSION.MICRO_VERSION
Exec=/opt/sagetv/client/sageclient.sh
TryExec=/opt/sagetv/client/sageclient.sh
Terminal=false
Categories=Applications;AudioVideo
Icon=SageIcon64.png


[Desktop Entry]
Name=Scalpel
GenericName=Audio Editor
Comment=An audio editor
Exec=scalpel %f
Terminal=false
Type=Application
Icon=editcut
Categories=Audio;AudioVideoEditing;
MimeType=audio/basic;audio/flac;audio/x-aiff;audio/x-wav;


Add Czech translation for input desktop file

Name[cs]=Klávesnice a myš
GenericName[cs]=Nastavení vstupních zařízení
Comment[cs]=Nastavování klávesnice, myši a dalších vstupních zařízení


Add Czech translation for config file associations desktop file

Name[cs]=Asociace typů souborů
GenericName[cs]=Nastavení asociace typů souborů
Comment[cs]=Nastavení přiřazení aplikací a souborů známých typů


Update Greek translation (el) Remove country variant from language code

Name[el]=Compton (Συνθέτης X)
GenericName[el]=Συνθέτης X
Comment[el]=Ένας συνθέτης X


[Desktop Entry]
Name=Kuma
Exec=/usr/bin/ignsdk -p /usr/share/ign-sdk/test/kuma.ign/
Icon=ignsdk-kuma
Terminal=false
Type=Application
Categories=Game


[Desktop Entry]
Version=1.0
Encoding=UTF-8
Name=FRESteamWorksTest
Comment=FRESteamWorksTest
Exec=./runLinux.sh
Type=Application
Categories=Network;
#Categories=Network;RemoteAccess;


Add desktop file to link to Github project.

[Desktop Entry]
Encoding=UTF-8
Name=github.com/nbeaver/tengwarscript-install-guide
Type=Link
URL=https://github.com/nbeaver/tengwarscript-install-guide
Icon=text-html


#!/usr/bin/env xdg-open
[Desktop Entry]
Version=1.0
Type=Application
Terminal=false
Icon[en_US]=gnome-panel-launcher
Exec=gnome-terminal -e '/home/factory/Avalon-extras/scripts/factory/loop.sh "./burn-mm.sh MM841"'
Name[en_US]=BurnAvalon8_841mm
Icon=gnome-panel-launcher


Add .desktop file for Linux distributions

[Desktop Entry]
Type=Application
Version=1.0
Name=Visram
GenericName=RAM/CPU Usage Visualizer
Comment=See a pie chart of your RAM or CPU usage
Exec=visram
Terminal=false
Categories=System;Monitor;


Add a desktop file to start input methods.

[Desktop Entry]
Name=Input Method
GenericName=Start Input Method
Comment=Start Input Method
Exec=/usr/lib/input-method/start-im
Terminal=false
Type=Application
StartupNotify=false
NoDisplay=true


[Desktop Entry]
Version=1.0
Name=Cura
GenericName=3D Printing Software
Comment=
Exec=/usr/bin/cura_app.py
TryExec=/usr/bin/cura_app.py
Icon=cura
Terminal=false
Type=Application
Categories=Graphics;
Keywords=3D;Printing;


#!/usr/bin/env xdg-open
[Desktop Entry]
Version=1.0
Type=Application
Name=livestreamer-gtkmm3
Comment=A GTKMM3 UI for livestreamer
Exec=livestreamer-gtkmm3
Icon=face-smile # yeah I need a better icon
Terminal=false
Categories=Network;


Add Debian desktop files, as per packaging policy

[Desktop Entry]
Version=1.0
Type=Application
Name=Allure of the Stars
Comment=Explore an abandoned spaceship with a party of adventurers
Keywords=game;strategy;tactics;roguelike;ascii;scifi;
Exec=Allure
Icon=allure
Terminal=false
Categories=Game;
StartupNotify=true


[Desktop Entry]
Type=Service
ServiceTypes=LxQtPanel/Plugin

Name=Network monitor
Comment=Displays network status and activity.

# Translations
Comment[nl]=Notepad
Name[nl]=Scherm notepad

Correct dutch translations for networkmonitor desktop file

[Desktop Entry]
Type=Service
ServiceTypes=LxQtPanel/Plugin

Name=Network monitor
Comment=Displays network status and activity.

# Translations
Name[nl]=Netwerkmonitor
Comment[nl]=Toont netwerkstatus en -activiteit


Update Greek translation Remove country variant from language code

Name[el]=Πρόσθετο ειδοποίησης κατάστασης
Comment[el]=Πρόσθετο ειδοποίησης κατάστασης


[Desktop Entry]
Name=Opsdroid Desktop
Type=Application
Exec=/etc/opsdroid-desktop/opsdroid-desktop
Terminal=false
Icon=/etc/opsdroid-desktop/resources/app/assets/icons/icon.png
Comment=A desktop client for opsdroid
NoDisplay=false
Categories=Development;chatbot
Name[en]=Opsdroid Desktop


Name[ar]=إدارة الطّاقة
GenericName[ar]=إعدادات إدارة الطّاقة
Comment[ar]=عدّة إعدادات لإدارة الطّاقة مثل مراقبات البطّاريّة أو الخمول


# Put this in /usr/share/xsessions
[Desktop Entry]
Name=Emacs
Comment=It's Emacs
Exec=emacs
TryExec=emacs
Type=Application
X-LightDM-DesktopName=Emacs
DesktopNames=Emacs


Revert "Migrate from Geary to Evolution."

[Desktop Entry]
Name[en_US]=Geary
Comment[en_US]=flatpak run org.gnome.Geary --hidden
Exec=flatpak run org.gnome.Geary --hidden
Icon=org.gnome.Geary
X-GNOME-Autostart-enabled=true
Type=Application


Add Czech translation for locale desktop file

Name[cs]=Místní a jazyková nastavení
GenericName[cs]=Místní a jazyková nastavení
Comment[cs]=Místní a jazyková nastavení pro LXQt


[Desktop Entry]
Version=1.0
Name=Solitaire Games
Comment=A collection of solitaire card games
Exec=qmlscene $@ /usr/share/solitaire-games/solitaire-games.qml
Icon=qmlscene
Terminal=false
Type=Application
Categories=Qt;Game;CardGame;
X-Ubuntu-Touch=true


[Desktop Entry]
Version=1.0
Name=Bitcoin Core
Comment=Connect to the Bitcoin P2P Network
Comment[de]=Verbinde mit dem Bitcoin peer-to-peer Netzwerk
Comment[fr]=Bitcoin, monnaie virtuelle cryptographique pair à pair
Comment[tr]=Bitcoin, eşten eşe kriptografik sanal para birimi
Exec=bitcoin-qt %u
Terminal=false
Type=Application
Icon=bitcoin128
MimeType=x-scheme-handler/bitcoin;
Categories=Office;Finance;
StartupWMClass=Bitcoin-qt

Add P2P, Network, and Qt categories to the desktop icon

[Desktop Entry]
Version=1.0
Name=Bitcoin Core
Comment=Connect to the Bitcoin P2P Network
Comment[de]=Verbinde mit dem Bitcoin peer-to-peer Netzwerk
Comment[fr]=Bitcoin, monnaie virtuelle cryptographique pair à pair
Comment[tr]=Bitcoin, eşten eşe kriptografik sanal para birimi
Exec=bitcoin-qt %u
Terminal=false
Type=Application
Icon=bitcoin128
MimeType=x-scheme-handler/bitcoin;
Categories=Office;Finance;P2P;Network;Qt;
StartupWMClass=Bitcoin-qt


[Desktop Entry]
Type=Application
Name=Synapse
Comment=Search everything you do.
Keywords=search;find;launch
Exec=bash -c 'GTK_IM_MODULE="" synapse'
Icon=synapse
Categories=GNOME;Utility;


[Desktop Entry]
Exec=lumina-info
Icon=/usr/local/share/pixmaps/Lumina-DE.png
Terminal=false
Type=Application
StartupNotify=true
Categories=System;
OnlyShowIn=Lumina
Name=Lumina Desktop Information
Comment=View information about the Lumina Desktop Environment

Fix the OnlyShowIn= entry to use "LUMINA" (all caps) since that is what is also set in the XDG_CURRENT_DESKTOP environment variable.

[Desktop Entry]
Exec=lumina-info
Icon=/usr/local/share/pixmaps/Lumina-DE.png
Terminal=false
Type=Application
StartupNotify=true
Categories=System;
OnlyShowIn=LUMINA
Name=Lumina Desktop Information
Comment=View information about the Lumina Desktop Environment


! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.smart environment fry
io.directories.search io.files io.pathnames io.standard-paths
kernel sequences sets splitting system unicode windows.shell32 ;
IN: io.standard-paths.windows

: program-files-directories ( -- array )
    [
        program-files
        program-files-x86
        "ProgramW6432" os-env
    ] output>array harvest members ; inline

: find-in-program-files ( base-directory quot -- path )
    [ program-files-directories ]
    [ '[ _ append-path ] map ]
    [ find-file-in-directories ] tri* ; inline

M: windows find-in-applications
    >lower
    '[ [ >lower _ tail? ] find-in-program-files ] map-find drop ;

M: windows find-in-path*
    [ "PATH" os-env ";" split ] dip
    '[ _ append-path exists? ] find nip ;

Add yet another path for Windows.

! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.smart environment fry
io.directories.search io.files io.pathnames io.standard-paths
kernel sequences sets splitting system unicode windows.shell32 ;
IN: io.standard-paths.windows

: program-files-directories ( -- array )
    [
        program-files
        program-files-x86
        "ProgramW6432" os-env
        "LOCALAPPDATA" os-env "Programs" append-path
    ] output>array harvest members ; inline

: find-in-program-files ( base-directory quot -- path )
    [ program-files-directories ]
    [ '[ _ append-path ] map ]
    [ find-file-in-directories ] tri* ; inline

M: windows find-in-applications
    >lower
    '[ [ >lower _ tail? ] find-in-program-files ] map-find drop ;

M: windows find-in-path*
    [ "PATH" os-env ";" split ] dip
    '[ _ append-path exists? ] find nip ;


USING: alien namespaces system combinators kernel sequences
vocabs vocabs.loader ;
IN: bootstrap.ui

"bootstrap.compiler" vocab [
    "ui-backend" get [
        {
            { [ os macosx? ] [ "cocoa" ] }
            { [ os windows? ] [ "windows" ] }
            { [ os unix? ] [ "x11" ] }
        } cond
    ] unless* "ui.backend." prepend require

    "ui-text-backend" get [
        {
            { [ os macosx? ] [ "core-text" ] }
            { [ os windows? ] [ "freetype" ] }
            { [ os unix? ] [ "freetype" ] }
        } cond
    ] unless* "ui.text." prepend require
] when

Use pango text backend by default on X11

USING: alien namespaces system combinators kernel sequences
vocabs vocabs.loader ;
IN: bootstrap.ui

"bootstrap.compiler" vocab [
    "ui-backend" get [
        {
            { [ os macosx? ] [ "cocoa" ] }
            { [ os windows? ] [ "windows" ] }
            { [ os unix? ] [ "x11" ] }
        } cond
    ] unless* "ui.backend." prepend require

    "ui-text-backend" get [
        {
            { [ os macosx? ] [ "core-text" ] }
            { [ os windows? ] [ "freetype" ] }
            { [ os unix? ] [ "pango" ] }
        } cond
    ] unless* "ui.text." prepend require
] when


! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
core-graphics.types kernel math.bitwise literals ;
IN: webkit-demo

FRAMEWORK: /System/Library/Frameworks/WebKit.framework
IMPORT: WebView

: rect ( -- rect ) 0 0 700 500 <CGRect> ;

: <WebView> ( -- id )
    WebView -> alloc
    rect f f -> initWithFrame:frameName:groupName: ;

CONSTANT: window-style ( -- n )
    flags{
        NSClosableWindowMask
        NSMiniaturizableWindowMask
        NSResizableWindowMask
        NSTitledWindowMask
    }

: <WebWindow> ( -- id )
    <WebView> rect window-style <ViewWindow> ;

: load-url ( window url -- )
    [ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;

: webkit-demo ( -- )
    <WebWindow>
    [ -> center ]
    [ f -> makeKeyAndOrderFront: ]
    [ "http://factorcode.org" load-url ] tri ;

: run-webkit-demo ( -- )
    [ webkit-demo ] cocoa-app ;

MAIN: run-webkit-demo

Fix typo in webkit demo

! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
core-graphics.types kernel math.bitwise literals ;
IN: webkit-demo

FRAMEWORK: /System/Library/Frameworks/WebKit.framework
IMPORT: WebView

: rect ( -- rect ) 0 0 700 500 <CGRect> ;

: <WebView> ( -- id )
    WebView -> alloc
    rect f f -> initWithFrame:frameName:groupName: ;

CONSTANT: window-style
    flags{
        NSClosableWindowMask
        NSMiniaturizableWindowMask
        NSResizableWindowMask
        NSTitledWindowMask
    }

: <WebWindow> ( -- id )
    <WebView> rect window-style <ViewWindow> ;

: load-url ( window url -- )
    [ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;

: webkit-demo ( -- )
    <WebWindow>
    [ -> center ]
    [ f -> makeKeyAndOrderFront: ]
    [ "http://factorcode.org" load-url ] tri ;

: run-webkit-demo ( -- )
    [ webkit-demo ] cocoa-app ;

MAIN: run-webkit-demo


! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs dns io.encodings.utf8 io.files kernel
math.statistics sequences splitting system unicode.categories ;
IN: dns.unix

: load-resolve.conf ( -- seq )
    "/etc/resolv.conf" utf8 file-lines
    [ [ blank? ] trim ] map
    [ "#" head? not ] filter
    [ [ " " split1 swap ] dip push-at ] sequence>hashtable "nameserver" swap at ;

M: unix initial-dns-servers load-resolve.conf ;

Remove blank lines from resolve.conf just in case

! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs dns io.encodings.utf8 io.files kernel
math.statistics sequences splitting system unicode.categories ;
IN: dns.unix

: load-resolve.conf ( -- seq )
    "/etc/resolv.conf" utf8 file-lines
    [ [ blank? ] trim ] map harvest
    [ "#" head? not ] filter
    [ [ " " split1 swap ] dip push-at ] sequence>hashtable "nameserver" swap at ;

M: unix initial-dns-servers load-resolve.conf ;


USING: accessors destructors kernel io.sockets io.sockets.icmp
sequences tools.test ;

IN: io.sockets.icmp.tests

[ { } ] [
    "localhost" <icmp> resolve-host
    [ [ icmp4? ] [ icmp6? ] bi or not ] filter
] unit-test

[ t ] [
    "127.0.0.1" <icmp4> <datagram>
    [ addr>> icmp4? ] with-disposal
] unit-test

Remove test for icmp sockets since extra/ping implicitly tests this


USING: yahoo help.syntax help.markup ;

HELP: search-yahoo
{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } }
{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ;

Fix yahoo for factor changes

USING: help.syntax help.markup ;
IN: yahoo

HELP: search-yahoo
{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } }
{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ;


IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval ;

DEFER: blah

[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test

[ t ] [ blah new sequence? ] unit-test

[ 3 ] [ 0 blah new nth-unsafe ] unit-test

[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test

[ f ] [ blah new sequence? ] unit-test

[ 0 blah new nth-unsafe ] must-fail

Fix another name clash in tests; putting all compiler tests in compiler.tests vocab is probably not good

IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval ;

DEFER: redefine2-test

[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test

[ t ] [ redefine2-test new sequence? ] unit-test

[ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test

[ ] [ [ redefine2-test sequence remove-mixin-instance ] with-compilation-unit ] unit-test

[ f ] [ redefine2-test new sequence? ] unit-test

[ 0 redefine2-test new nth-unsafe ] must-fail


USING: kernel stack-checker.transforms struct-arrays.private ;
IN: struct-arrays

: struct-element-constructor ( c-type -- word )
    "Struct array usages must be compiled" throw ;

<<

\ struct-element-constructor [
    (struct-element-constructor) [ ] curry
] 1 define-transform

>>

Fix tree shaker again, gah

USING: kernel stack-checker.transforms ;
IN: struct-arrays.private

: struct-element-constructor ( c-type -- word )
    "Struct array usages must be compiled" throw ;

<<

\ struct-element-constructor [
    (struct-element-constructor) [ ] curry
] 1 define-transform

>>


USING: help.syntax help.markup ;
IN: yahoo

HELP: search-yahoo
{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } }
{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ;

Fix help lint failure in yahoo

USING: help.syntax help.markup ;
IN: yahoo

HELP: search-yahoo
{ $values { "search" search } { "seq" "sequence of arrays of length 3" } }
{ $description "Uses Yahoo's REST API to search for the specified query, getting the number of answers specified. Returns a sequence of " { $link result } " instances." } ;


! Copyright (C) 2008, 2010 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.files.temp io words alien kernel math.parser
alien.syntax io.launcher assocs arrays sequences namespaces make
system math io.encodings.ascii accessors tools.disassembler
tools.disassembler.private ;
IN: tools.disassembler.gdb

SINGLETON: gdb-disassembler

: in-file ( -- path ) "gdb-in.txt" temp-file ;

: out-file ( -- path ) "gdb-out.txt" temp-file ;

: make-disassemble-cmd ( from to -- )
    in-file ascii [
        "attach " write
        current-process-handle number>string print
        "disassemble " write
        [ number>string write bl ] bi@
    ] with-file-writer ;

: gdb-binary ( -- string ) "gdb" ;

: run-gdb ( -- lines )
    <process>
        +closed+ >>stdin
        out-file >>stdout
        [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
    try-process
    out-file ascii file-lines ;

M: gdb-disassembler disassemble*
    make-disassemble-cmd run-gdb ;

gdb-disassembler disassembler-backend set-global

Fix GDB-based disassemble for GDB 7

! Copyright (C) 2008, 2010 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.files.temp io words alien kernel math.parser
alien.syntax io.launcher assocs arrays sequences namespaces make
system math io.encodings.ascii accessors tools.disassembler
tools.disassembler.private locals ;
IN: tools.disassembler.gdb

SINGLETON: gdb-disassembler

: in-file ( -- path ) "gdb-in.txt" temp-file ;

: out-file ( -- path ) "gdb-out.txt" temp-file ;

:: make-disassemble-cmd ( from to -- )
    in-file ascii [
        "attach " write
        current-process-handle number>string print
        "x/" write to from - 4 / number>string write
        "i" write bl from number>string write
    ] with-file-writer ;

: gdb-binary ( -- string ) "gdb" ;

: run-gdb ( -- lines )
    <process>
        +closed+ >>stdin
        out-file >>stdout
        [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
    try-process
    out-file ascii file-lines ;

M: gdb-disassembler disassemble*
    make-disassemble-cmd run-gdb ;

gdb-disassembler disassembler-backend set-global


USING: generic kernel kernel.private math memory prettyprint io
sequences tools.test words namespaces layouts classes
classes.builtin arrays quotations io.launcher system ;
IN: memory.tests

! LOL
[ ] [
    vm
    "-generations=2"
    "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit"
    3array try-process
] unit-test

[ [ ] instances ] must-infer

! Code GC wasn't kicking in when needed
: leak-step 800000 f <array> 1quotation call drop ;

: leak-loop 100 [ leak-step ] times ;

[ ] [ leak-loop ] unit-test

TUPLE: testing x y z ;

[ save-image-and-exit ] must-fail

[ ] [
    num-types get [
        type>class [
            dup . flush
            "predicate" word-prop instances [
                class drop
            ] each
        ] when*
    ] each
] unit-test

! Erg's bug
2 [ [ [ 3 throw ] instances ] must-fail ] times

Fix memory test on OpenBSD

USING: generic kernel kernel.private math memory prettyprint io
sequences tools.test words namespaces layouts classes
classes.builtin arrays quotations io.launcher system ;
IN: memory.tests

! LOL
[ ] [
    vm
    "-i=" image append
    "-generations=2"
    "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit"
    4array try-process
] unit-test

[ [ ] instances ] must-infer

! Code GC wasn't kicking in when needed
: leak-step 800000 f <array> 1quotation call drop ;

: leak-loop 100 [ leak-step ] times ;

[ ] [ leak-loop ] unit-test

TUPLE: testing x y z ;

[ save-image-and-exit ] must-fail

[ ] [
    num-types get [
        type>class [
            dup . flush
            "predicate" word-prop instances [
                class drop
            ] each
        ] when*
    ] each
] unit-test

! Erg's bug
2 [ [ [ 3 throw ] instances ] must-fail ] times


USING: kernel math math.parser random io ;
IN: numbers-game

: read-number ( -- n ) readln string>number ;

: guess-banner ( -- )
    "I'm thinking of a number between 0 and 100." print ;
: guess-prompt ( -- ) "Enter your guess: " write ;
: too-high ( -- ) "Too high" print ;
: too-low ( -- ) "Too low" print ;
: correct ( -- ) "Correct - you win!" print ;

: inexact-guess ( actual guess -- )
     < [ too-high ] [ too-low ] if ;

: judge-guess ( actual guess -- ? )
    2dup = [ 2drop correct f ] [ inexact-guess t ] if ;

: number-to-guess ( -- n ) 100 random ;

: numbers-game-loop ( actual -- )
    dup guess-prompt read-number judge-guess
    [ numbers-game-loop ] [ drop ] if ;

: numbers-game ( -- ) number-to-guess numbers-game-loop ;

MAIN: numbers-game

Add the banner. It should give the instructions before asking for a guess.

USING: kernel math math.parser random io ;
IN: numbers-game

: read-number ( -- n ) readln string>number ;

: guess-banner ( -- )
    "I'm thinking of a number between 0 and 100." print ;
: guess-prompt ( -- ) "Enter your guess: " write ;
: too-high ( -- ) "Too high" print ;
: too-low ( -- ) "Too low" print ;
: correct ( -- ) "Correct - you win!" print ;

: inexact-guess ( actual guess -- )
     < [ too-high ] [ too-low ] if ;

: judge-guess ( actual guess -- ? )
    2dup = [ 2drop correct f ] [ inexact-guess t ] if ;

: number-to-guess ( -- n ) 100 random ;

: numbers-game-loop ( actual -- )
    dup guess-prompt read-number judge-guess
    [ numbers-game-loop ] [ drop ] if ;

: numbers-game ( -- )
    guess-banner number-to-guess numbers-game-loop ;

MAIN: numbers-game


! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
IN: project-euler.002

! http://projecteuler.net/index.php?section=problems&id=2

! DESCRIPTION
! -----------

! Each new term in the Fibonacci sequence is generated by adding the previous
! two terms. By starting with 1 and 2, the first 10 terms will be:

!     1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...

! Find the sum of all the even-valued terms in the sequence which do not exceed one million.

! SOLUTION
! --------

<PRIVATE

: (fib-upto) ( seq n limit -- seq )
    2dup <= [ >r add dup 2 tail* sum r> (fib-upto) ] [ 2drop ] if ;

PRIVATE>

: fib-upto ( n -- seq )
    { 0 } 1 rot (fib-upto) ;

: euler002 ( -- answer )
    1000000 fib-upto [ even? ] subset sum ;

! [ euler002 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials

MAIN: euler002

Use vectors instead of arrays in solution to Project Euler problem 2

! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
IN: project-euler.002

! http://projecteuler.net/index.php?section=problems&id=2

! DESCRIPTION
! -----------

! Each new term in the Fibonacci sequence is generated by adding the previous
! two terms. By starting with 1 and 2, the first 10 terms will be:

!     1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...

! Find the sum of all the even-valued terms in the sequence which do not exceed one million.

! SOLUTION
! --------

<PRIVATE

: (fib-upto) ( seq n limit -- seq )
    2dup <= [ [ over push dup 2 tail* sum ] dip (fib-upto) ] [ 2drop ] if ;

PRIVATE>

: fib-upto ( n -- seq )
    V{ 0 } clone 1 rot (fib-upto) ;

: euler002 ( -- answer )
    1000000 fib-upto [ even? ] subset sum ;

! [ euler002 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials

MAIN: euler002


! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
       arrays classes.tuple math.order words assocs
       irc.messages.base sequences ;
IN: irc.messages.parser

<PRIVATE
: split-at-first ( seq separators -- before after )
    dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;

: split-trailing ( string -- string string/f ) ":" split1 ;
: remove-heading-: ( seq -- seq ) ":" ?head drop ;

: split-prefix ( string -- string/f string )
    dup ":" head? [
        remove-heading-: " " split1
    ] [ f swap ] if ;

: split-message ( string -- prefix command parameters trailing )
    split-prefix split-trailing
    [ [ blank? ] trim " " split unclip swap ] dip ;

: sender ( irc-message -- sender )
    prefix>> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ;
PRIVATE>

: string>irc-message ( string -- irc-message )
    dup split-message
    [ [ irc>type new ] [ >>command ] bi ]
    [ >>parameters ]
    [ >>trailing ]
    tri*
    [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
    now >>timestamp dup sender >>sender ;

Use GMT times when building a message

! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
       arrays classes.tuple math.order words assocs
       irc.messages.base sequences ;
IN: irc.messages.parser

<PRIVATE
: split-at-first ( seq separators -- before after )
    dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;

: split-trailing ( string -- string string/f ) ":" split1 ;
: remove-heading-: ( seq -- seq ) ":" ?head drop ;

: split-prefix ( string -- string/f string )
    dup ":" head? [
        remove-heading-: " " split1
    ] [ f swap ] if ;

: split-message ( string -- prefix command parameters trailing )
    split-prefix split-trailing
    [ [ blank? ] trim " " split unclip swap ] dip ;

: sender ( irc-message -- sender )
    prefix>> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ;
PRIVATE>

: string>irc-message ( string -- irc-message )
    dup split-message
    [ [ irc>type new ] [ >>command ] bi ]
    [ >>parameters ]
    [ >>trailing ]
    tri*
    [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
    gmt >>timestamp dup sender >>sender ;


USING: system-info.linux strings splitting sequences
tools.test ;
IN: system-info.linux.tests

[ 6 ] [ uname length ] unit-test

[ t ] [ sysname    string? ] unit-test
[ t ] [ nodename   string? ] unit-test
[ t ] [ release    string? ] unit-test
[ t ] [ version    string? ] unit-test
[ t ] [ machine    string? ] unit-test
[ t ] [ domainname string? ] unit-test

[ t ] [
    release "." split1 drop { "2" "3" } member?
] unit-test

Fix a using in system-info.linux

USING: system-info.linux strings splitting sequences
tools.test kernel ;
IN: system-info.linux.tests

[ 6 ] [ uname length ] unit-test

[ t ] [ sysname    string? ] unit-test
[ t ] [ nodename   string? ] unit-test
[ t ] [ release    string? ] unit-test
[ t ] [ version    string? ] unit-test
[ t ] [ machine    string? ] unit-test
[ t ] [ domainname string? ] unit-test

[ t ] [
    release "." split1 drop { "2" "3" } member?
] unit-test


! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test io.files.listing strings kernel ;
IN: io.files.listing.tests

[ ] [ "" directory. ] unit-test

Add unit test to assert that directory. can infeR

! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test io.files.listing strings kernel ;
IN: io.files.listing.tests

\ directory. must-infer

[ ] [ "" directory. ] unit-test


! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.cleanup
compiler.tree.escape-analysis
compiler.tree.escape-analysis.check
compiler.tree.tuple-unboxing
compiler.tree.identities
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.modular-arithmetic
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer

SYMBOL: check-optimizer?

: ?check ( nodes -- nodes' )
    check-optimizer? get [
        compute-def-use
        dup check-nodes
    ] when ;

: optimize-tree ( nodes -- nodes' )
    analyze-recursive
    normalize
    propagate
    cleanup
    dup run-escape-analysis? [
        escape-analysis
        unbox-tuples
    ] when
    apply-identities
    compute-def-use
    remove-dead-code
    ?check
    compute-def-use
    optimize-modular-arithmetic
    finalize ;

Add a with-scope so that optimize-tree doesn't pollute namespace

! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.cleanup
compiler.tree.escape-analysis
compiler.tree.escape-analysis.check
compiler.tree.tuple-unboxing
compiler.tree.identities
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.modular-arithmetic
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer

SYMBOL: check-optimizer?

: ?check ( nodes -- nodes' )
    check-optimizer? get [
        compute-def-use
        dup check-nodes
    ] when ;

: optimize-tree ( nodes -- nodes' )
    [
        analyze-recursive
        normalize
        propagate
        cleanup
        dup run-escape-analysis? [
            escape-analysis
            unbox-tuples
        ] when
        apply-identities
        compute-def-use
        remove-dead-code
        ?check
        compute-def-use
        optimize-modular-arithmetic
        finalize
    ] with-scope ;


IN: tools.vocabs.browser.tests
USING: tools.vocabs.browser tools.test help.markup ;

[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test

Add a failing unit test

IN: tools.vocabs.browser.tests
USING: tools.vocabs.browser tools.test help.markup help vocabs ;

[ ] [ { $vocab "scratchpad" } print-content ] unit-test
[ ] [ "classes" vocab print-topic ] unit-test


! Copyright (C) 2012 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test machine-learning.one-hot ;
IN: machine-learning.one-hot.tests

CONSTANT: test-data {
    { "male" "female" }
    { "from Europe" "from US" "from Asia" }
    { "uses Firefox" "uses Chrome" "uses Safari" "uses Internet Explorer" }
}

{ { 1 0 0 1 0 0 0 0 1 } }
[ { 0 1 3 } test-data one-hot ] unit-test

Use the example from my blog post as a unit test.

! Copyright (C) 2012 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test machine-learning.one-hot ;
IN: machine-learning.one-hot.tests

CONSTANT: test-data {
    { "hot" "cold" }
    { "cloudy" "raining" "snowing" "sunny" }
    { "light" "heavy" }
    { "bright-colored" "dark-colored" "neutral" }
    { "quickly" "slowly" }
    { "well" "sick" "tired" }
}

{ { 1 0 0 0 0 1 1 0 0 0 1 0 1 1 0 0 } }
[ { 0 3 0 2 1 0 } test-data one-hot ] unit-test

{ { 0 1 0 0 1 0 0 1 0 1 0 1 0 0 1 0 } }
[ { 1 2 1 1 0 1 } test-data one-hot ] unit-test


USING: help.markup help.syntax math sequences ;
IN: hash-sets

ARTICLE: "hash-sets" "Hash sets"
"The " { $vocab-link "hash-sets" } " vocabulary implements hashtable-like sets. Hash sets form a class:"
{ $subsections hash-set }
"Constructing new hash sets:"
{ $subsections <hash-set> >hash-set }
"The syntax for hash sets is described in " { $link "syntax-hash-sets" } "." ;

ABOUT: "hash-sets"

HELP: hash-set
{ $class-description "The class of hashtable-like sets. These implement the " { $link "sets" } "." } ;

HELP: <hash-set>
{ $values { "capacity" number } { "hash-set" hash-set } }
{ $description "Creates a new hash set capable of storing " { $snippet "capacity" } " elements before growing." } ;

HELP: >hash-set
{ $values { "members" sequence } { "hash-set" hash-set } }
{ $description "Creates a new hash set with the given members." } ;

Fix typo in hash-set documentation

USING: help.markup help.syntax math sequences sets ;
IN: hash-sets

ARTICLE: "hash-sets" "Hash sets"
"The " { $vocab-link "hash-sets" } " vocabulary implements hashtable-like sets. Hash sets form a class:"
{ $subsections hash-set }
"Constructing new hash sets:"
{ $subsections <hash-set> >hash-set }
"The syntax for hash sets is described in " { $link "syntax-hash-sets" } "." ;

ABOUT: "hash-sets"

HELP: hash-set
{ $class-description "The class of hashtable-like sets. These implement the " { $link set } " mixin." } ;

HELP: <hash-set>
{ $values { "capacity" number } { "hash-set" hash-set } }
{ $description "Creates a new hash set capable of storing " { $snippet "capacity" } " elements before growing." } ;

HELP: >hash-set
{ $values { "members" sequence } { "hash-set" hash-set } }
{ $description "Creates a new hash set with the given members." } ;


! Copyright (C) 2015 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: editors kernel make memoize namespaces system vocabs ;
IN: editors.visual-studio-code

SINGLETON: visual-studio-code
visual-studio-code editor-class set-global

HOOK: find-visual-studio-code-invocation os ( -- array )

MEMO: visual-studio-code-invocation ( -- array )
    \ visual-studio-code-invocation get [
        find-visual-studio-code-invocation
        [ { "code" } ] unless*
    ] unless* ;

M: macosx find-visual-studio-code-invocation
    { "open" "-n" "-b" "com.microsoft.VSCode" "--args" } ;

M: visual-studio-code editor-command ( file line -- command )
    [
        visual-studio-code-invocation % drop ,
    ] { } make ;

os windows? [ "editors.visual-studio-code.windows" require ] when

Make Visual Studio Code integration go directly to lines

! Copyright (C) 2015 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: editors kernel make math.parser memoize namespaces
sequences system vocabs ;
IN: editors.visual-studio-code

SINGLETON: visual-studio-code
visual-studio-code editor-class set-global

HOOK: find-visual-studio-code-invocation os ( -- array )

MEMO: visual-studio-code-invocation ( -- array )
    \ visual-studio-code-invocation get [
        find-visual-studio-code-invocation
        [ { "code" } ] unless*
    ] unless* ;

M: macosx find-visual-studio-code-invocation
    { "open" "-n" "-b" "com.microsoft.VSCode" "--args" } ;

M: visual-studio-code editor-command ( file line -- command )
    [
        visual-studio-code-invocation % "-g" ,
        number>string ":" glue ,
    ] { } make ;

os windows? [ "editors.visual-studio-code.windows" require ] when


! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.expr multiline sequences ;
IN: temporary

{ 5 } [
  "2+3" eval-expr
] unit-test

{ 6 } [
  "2*3" eval-expr
] unit-test

{ 14 } [
  "2+3*4" eval-expr
] unit-test

{ 17 } [
  "2+3*4+3" eval-expr
] unit-test

{ 23 } [
  "2+3*(4+3)" eval-expr
] unit-test

Fix vocab name in expr tests

! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.expr multiline sequences ;
IN: peg.expr.tests

{ 5 } [
  "2+3" eval-expr
] unit-test

{ 6 } [
  "2*3" eval-expr
] unit-test

{ 14 } [
  "2+3*4" eval-expr
] unit-test

{ 17 } [
  "2+3*4+3" eval-expr
] unit-test

{ 23 } [
  "2+3*(4+3)" eval-expr
] unit-test


! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel lazy-lists math math.erato math.functions math.ranges
       namespaces sequences ;
IN: project-euler.010

! http://projecteuler.net/index.php?section=problems&id=10

! DESCRIPTION
! -----------

! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17.

! Find the sum of all the primes below one million.

! SOLUTION
! --------

! Sieve of Eratosthenes and lazy summing

: euler010 ( -- answer )
    0 1000000 lerato [ + ] leach ;

! TODO: solution is still too slow for 1000000, probably due to seq-diff
! calling member? for each number that we want to remove

! [ euler010 ] time
! 765 ms run / 7 ms GC time

MAIN: euler010

Remove obsolete performance comment on project Euler problem 10

! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel lazy-lists math math.erato math.functions math.ranges
       namespaces sequences ;
IN: project-euler.010

! http://projecteuler.net/index.php?section=problems&id=10

! DESCRIPTION
! -----------

! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17.

! Find the sum of all the primes below one million.

! SOLUTION
! --------

! Sieve of Eratosthenes and lazy summing

: euler010 ( -- answer )
    0 1000000 lerato [ + ] leach ;

! [ euler010 ] time
! 765 ms run / 7 ms GC time

MAIN: euler010


! Copyright (C) 2014 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.strings
combinators destructors forestdb.ffi fry io.pathnames kernel
libc namespaces sequences tools.test ;
IN: forestdb.lib

CONSTANT: forestdb-test-path "resource:forestdbs/first.fdb"

{ "val123" } [
    forestdb-test-path [
       "key123" "val123" fdb-set
       "key123" fdb-get
    ] with-forestdb
] unit-test

{ "val12345" } [
    forestdb-test-path [
       "key123" "val12345" fdb-set
       "key123" fdb-get
    ] with-forestdb
] unit-test

Fix file name for test db.

! Copyright (C) 2014 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.strings
combinators destructors forestdb.ffi fry io.files.temp
io.pathnames kernel libc namespaces sequences tools.test ;
IN: forestdb.lib

: forestdb-test-path ( -- path )
    "forestdb-test.fdb" temp-file ;

{ "val123" } [
    forestdb-test-path [
       "key123" "val123" fdb-set
       "key123" fdb-get
    ] with-forestdb
] unit-test

{ "val12345" } [
    forestdb-test-path [
       "key123" "val12345" fdb-set
       "key123" fdb-get
    ] with-forestdb
] unit-test


! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors debugger continuations threads threads.private
io io.styles prettyprint kernel math.parser namespaces ;
IN: debugger.threads

: error-in-thread. ( thread -- )
    "Error in thread " write
    [
        dup id>> #
        " (" % dup name>> %
        ", " % dup quot>> unparse-short % ")" %
    ] "" make swap write-object ":" print nl ;

M: thread error-in-thread ( error thread -- )
    initial-thread get-global eq? [
        die drop
    ] [
        global [
            error-thread get-global error-in-thread. print-error flush
        ] bind
    ] if ;

[ self error-in-thread stop ]
thread-error-hook set-global

Print call stack trace for thread errors

! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors debugger continuations threads threads.private
io io.styles prettyprint kernel math.parser namespaces ;
IN: debugger.threads

: error-in-thread. ( thread -- )
    "Error in thread " write
    [
        dup id>> #
        " (" % dup name>> %
        ", " % dup quot>> unparse-short % ")" %
    ] "" make swap write-object ":" print ;

M: thread error-in-thread ( error thread -- )
    initial-thread get-global eq? [
        die drop
    ] [
        global [
            error-thread get-global error-in-thread. nl
            print-error nl
            :c
            flush
        ] bind
    ] if ;

[ self error-in-thread stop ]
thread-error-hook set-global


USING: compiler.units words tools.test math kernel ;
IN: compiler.tests.redefine15

DEFER: word-1

: word-2 ( a -- b ) word-1 ;

[ \ word-1 [ ] (( a -- b )) define-declared ] with-compilation-unit

[ "a" ] [ "a" word-2 ] unit-test

: word-3 ( a -- b ) 1 + ;

: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ;

[ 1 1 ] [ 0 word-4 ] unit-test

[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit

[ 2 3 ] [ 0 word-4 ] unit-test


IN: io.monitors.tests
USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
threads calendar ;

os { winnt macosx linux } member? [
    [ "monitor-test" temp-file delete-tree ] ignore-errors

    [ ] [ "monitor-test" temp-file make-directory ] unit-test

    [ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test

    [ ] [ 1 <count-down> "c" set ] unit-test

    [ ] [
        [
           [
               "m" get next-change drop
               dup print flush
               "test.txt" tail? not
           ] [ ] [ ] while
           "c" get count-down
        ] "Monitor test thread" spawn drop
    ] unit-test

    [ ] [ "monitor-test/test.txt" touch-file ] unit-test

    [ ] [ "c" get 30 seconds await-timeout ] unit-test
] when


IN: ui.gadgets.glass.tests
USING: tools.test ui.gadgets.glass ui.gadgets.worlds ui.gadgets
math.rectangles namespaces accessors models ;

<gadget> "" f <model> <world>
{ 1000 1000 } >>dim
"w" set

[ ] [ <gadget> "g" set ] unit-test

[ ] [ "w" get "g" get { 0 0 } { 100 100 } <rect> show-glass ] unit-test

[ ] [ "g" get hide-glass ] unit-test

[ f ] [ "g" get parent>> ] unit-test

[ t ] [ "w" get layers>> empty? ] unit-test


! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-graphics kernel ;
IN: core-graphics.tests

[ ] [ 100 200 [ drop ] with-bitmap-context ] unit-test

Fix core graphics unit test

! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-graphics kernel byte-arrays ;
IN: core-graphics.tests

[ t ] [ 100 200 [ drop ] with-bitmap-context byte-array? ] unit-test


! Copyright (c) 2007 Aaron Schaefer
! See http://factorcode.org/license.txt for BSD license.
USING: arrays effects inference io kernel math math.functions math.parser
    math.statistics namespaces sequences tools.time ;
IN: project-euler.ave-time

<PRIVATE

: clean-stack ( quot -- )
    infer dup effect-out swap effect-in - [ drop ] times ;

: ave-benchmarks ( seq -- pair )
    flip [ mean round ] map ;

PRIVATE>

: collect-benchmarks ( quot n -- seq )
    [
        1- [ [ benchmark ] keep -rot 2array , [ clean-stack ] keep ] times
    ] curry { } make >r benchmark 2array r> swap add ; inline

: ave-time ( quot n -- )
    [ collect-benchmarks ] keep swap ave-benchmarks [
        dup second # " ms run / " % first # " ms GC ave time - " % # " trials" %
    ] "" make print flush ; inline

Update collect-benchmarks so that it does not rely onto computed stack effect

! Copyright (c) 2007 Aaron Schaefer
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators io kernel math math.functions math.parser
    math.statistics namespaces sequences tools.time ;
IN: project-euler.ave-time

<PRIVATE

: ave-benchmarks ( seq -- pair )
    flip [ mean round ] map ;

PRIVATE>

: collect-benchmarks ( quot n -- seq )
  [
    >r >r datastack r> [ benchmark 2array , ] curry tuck
    [ with-datastack drop ] 2curry r> swap times call
  ] { } make ;

: ave-time ( quot n -- )
    [ collect-benchmarks ] keep swap ave-benchmarks [
        dup second # " ms run / " % first # " ms GC ave time - " % # " trials" %
    ] "" make print flush ; inline


IN: specialized-vectors.tests
USING: specialized-vectors.double tools.test kernel sequences ;

[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test

Add test to assert that new-resizable returns specialized vectors on specialized arrays

IN: specialized-vectors.tests
USING: specialized-arrays.float
specialized-vectors.float
specialized-vectors.double
tools.test kernel sequences ;

[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test

[ t ] [ 10 float-array{ } new-resizable float-vector? ] unit-test


! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax byte-arrays strings ;
IN: io.encodings.string

ARTICLE: "io.encodings.string" "Encoding and decoding strings"
"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
{ $link "encodings-descriptors" } " to the following words:"
{ $subsections
    encode
    decode
} ;

HELP: decode
{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" }
    { "string" string } }
{ $description "Decodes the byte array using the given encoding, outputting a string" } ;

HELP: encode
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Encodes the given string into a byte array with the given encoding." } ;

Add examples to encode/decode docs.

! Copyright (C) 2008,2011 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays help.markup help.syntax io.encodings.string
strings ;
IN: io.encodings.string

ARTICLE: "io.encodings.string" "Encoding and decoding strings"
"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
{ $link "encodings-descriptors" } " to the following words:"
{ $subsections
    encode
    decode
} ;

HELP: decode
{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" }
    { "string" string } }
{ $description "Converts an array of bytes to a string, interpreting that array of bytes as a string with the given encoding." }
{ $examples
    { $example """USING: io.encodings.string io.encodings.utf8 prettyprint ;
B{ 230 136 145 231 136 177 228 189 160 } utf8 decode ."""
""""我爱你""""
    }
} ;

HELP: encode
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Converts a string into a byte array, interpreting that string with the given encoding." }
{ $examples
    { $example """USING: io.encodings.string io.encodings.utf8 prettyprint ;
"我爱你" utf8 encode ."""
"B{ 230 136 145 231 136 177 228 189 160 }"
    }
} ;


! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download

: url URL" http://factorcode.org/images/latest/" ;

: download-checksums ( -- alist )
    url "checksums.txt" >url derive-url http-get nip
    string-lines [ " " split1 ] { } map>assoc ;

: need-new-image? ( image -- ? )
    dup exists?
    [
        [ openssl-md5 checksum-file hex-string ]
        [ download-checksums at ]
        bi = not
    ] [ drop t ] if ;

: download-image ( arch -- )
    boot-image-name dup need-new-image? [
        "Downloading " write dup write "..." print
         url over >url derive-url download
         need-new-image? [
             "Boot image corrupt, or checksums.txt on server out of date" throw
         ] when
    ] [
        "Boot image up to date" print
        drop
    ] if ;

: download-my-image ( -- ) my-arch download-image ;

MAIN: download-my-image

Use our MD5 library instead of OpenSSL so that we can run builder without OpenSSL being installed

! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download

: url URL" http://factorcode.org/images/latest/" ;

: download-checksums ( -- alist )
    url "checksums.txt" >url derive-url http-get nip
    string-lines [ " " split1 ] { } map>assoc ;

: need-new-image? ( image -- ? )
    dup exists?
    [
        [ md5 checksum-file hex-string ]
        [ download-checksums at ]
        bi = not
    ] [ drop t ] if ;

: download-image ( arch -- )
    boot-image-name dup need-new-image? [
        "Downloading " write dup write "..." print
         url over >url derive-url download
         need-new-image? [
             "Boot image corrupt, or checksums.txt on server out of date" throw
         ] when
    ] [
        "Boot image up to date" print
        drop
    ] if ;

: download-my-image ( -- ) my-arch download-image ;

MAIN: download-my-image


! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots kernel sequences fry accessors parser lexer words
effects.parser ;
IN: constructors

! An experiment

: constructor-quot ( class slot-names body -- quot )
    [ <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ] dip
    '[ _ new @ @ ] ;

: define-constructor ( name class effect body -- )
    [ [ in>> ] dip constructor-quot ] [ drop ] 2bi
    define-declared ;

: CONSTRUCTOR:
    scan-word [ name>> "<" ">" surround create-in ] keep
    "(" expect ")" parse-effect
    parse-definition
    define-constructor ; parsing

Clean up CONSTRUCTOR: with Dan's idea: introduce set-slots and construct macros

! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots kernel sequences fry accessors parser lexer words
effects.parser macros ;
IN: constructors

! An experiment

MACRO: set-slots ( slots -- quot )
    <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;

: construct ( ... class slots -- instance )
    [ new ] dip set-slots ; inline

: define-constructor ( name class effect body -- )
    [ [ in>> ] dip '[ _ _ construct @ ] ] [ drop ] 2bi
    define-declared ;

: CONSTRUCTOR:
    scan-word [ name>> "<" ">" surround create-in ] keep
    "(" expect ")" parse-effect
    parse-definition
    define-constructor ; parsing


IN: io.monitors.freebsd

! Empty for now

Fix monitor errors on startup

USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.pathnames io.buffers io.ports io.timeouts
io.backend.unix io.encodings.utf8 assocs namespaces make
sequences locals system destructors accessors o;
IN: io.monitors.freebsd

TUPLE: freebsd-monitor < monitor handle ;

M:: freebsd (monitor) ( path recursive? mailbox -- monitor )
    path normalize-path :> path
    path mailbox freebsd-monitor new-monitor ;

M: freebsd-monitor dispose*
    [ handle>> dispose ] [ call-next-method ] bi ;

freebsd set-io-backend


Add a modern functors file that doesn't have the FUNCTOR-SYNTAX: words.

! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.mixin classes.parser
classes.singleton classes.tuple classes.tuple.parser
combinators effects.parser fry functors.backend generic
generic.parser interpolate io.streams.string kernel lexer
locals.parser locals.types macros make namespaces parser
quotations sequences vocabs.parser words words.symbol ;
IN: functors

! This is a hack

<PRIVATE

TUPLE: fake-call-next-method ;

TUPLE: fake-quotation seq ;

GENERIC: >fake-quotations ( quot -- fake )

M: callable >fake-quotations
    >array >fake-quotations fake-quotation boa ;

M: array >fake-quotations [ >fake-quotations ] { } map-as ;

M: object >fake-quotations ;

GENERIC: (fake-quotations>) ( fake -- )

: fake-quotations> ( fake -- quot )
    [ (fake-quotations>) ] [ ] make ;

M: fake-quotation (fake-quotations>)
    [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;

M: array (fake-quotations>)
    [ [ (fake-quotations>) ] each ] { } make , ;

M: fake-call-next-method (fake-quotations>)
    drop \ method get literalize , \ (call-next-method) , ;

M: object (fake-quotations>) , ;

: parse-definition* ( accum -- accum )
    parse-definition >fake-quotations suffix!
    [ fake-quotations> first ] append! ;

: parse-declared* ( accum -- accum )
    scan-effect
    [ parse-definition* ] dip
    suffix! ;

: (INTERPOLATE) ( accum quot -- accum )
    [ scan-token interpolate-locals ] dip
    '[ _ with-string-writer @ ] suffix! ;

PRIVATE>

DEFER: ;FUNCTOR delimiter

<PRIVATE

: push-functor-words ( -- )
    functor-words use-words ;

: pop-functor-words ( -- )
    functor-words unuse-words ;

: (parse-bindings) ( end -- words )
    [ dup parse-binding dup ]
    [ first2 [ make-local ] dip 2array ]
    produce 2nip ;

: with-bindings ( quot -- words assoc )
    in-lambda? on H{ } make ; inline

: parse-bindings ( end -- words assoc )
    [
        building get use-words
        (parse-bindings)
        building get unuse-words
    ] with-bindings ;

: parse-functor-body ( -- form )
    push-functor-words
    "WHERE" parse-bindings
    [ [ swap <def> suffix ] { } assoc>map concat ]
    [ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi*
    [ ] append-as
    pop-functor-words ;

: (FUNCTOR:) ( -- word def effect )
    scan-new-word [ parse-functor-body ] parse-locals-definition ;

PRIVATE>


USING: generic kernel kernel.private math memory prettyprint
sequences tools.test words namespaces layouts classes
classes.builtin ;
IN: memory.tests

TUPLE: testing x y z ;

[ save-image-and-exit ] must-fail

[ ] [
    num-types get [
        type>class [
            "predicate" word-prop instances [
                class drop
            ] each
        ] when*
    ] each
] unit-test

Add test case for GC

USING: generic kernel kernel.private math memory prettyprint
sequences tools.test words namespaces layouts classes
classes.builtin arrays quotations ;
IN: memory.tests

! Code GC wasn't kicking in when needed
: leak-step 800000 f <array> 1quotation call drop ;

: leak-loop 100 [ leak-step ] times ;

[ ] [ leak-step leak-step leak-step data-gc ] unit-test

[ ] [ leak-loop ] unit-test

TUPLE: testing x y z ;

[ save-image-and-exit ] must-fail

[ ] [
    num-types get [
        type>class [
            "predicate" word-prop instances [
                class drop
            ] each
        ] when*
    ] each
] unit-test


USING: alien namespaces system combinators kernel sequences
vocabs vocabs.loader ;
IN: bootstrap.ui

"bootstrap.compiler" vocab [
    "ui-backend" get [
        {
            { [ os macosx? ] [ "cocoa" ] }
            { [ os windows? ] [ "windows" ] }
            { [ os unix? ] [ "x11" ] }
        } cond
    ] unless* "ui.backend." prepend require

    "ui-text-backend" get [
        {
            { [ os macosx? ] [ "core-text" ] }
            { [ os windows? ] [ "freetype" ] }
            { [ os unix? ] [ "pango" ] }
        } cond
    ] unless* "ui.text." prepend require
] when

Use Pango text rendering on Windows

USING: alien namespaces system combinators kernel sequences
vocabs vocabs.loader ;
IN: bootstrap.ui

"bootstrap.compiler" vocab [
    "ui-backend" get [
        {
            { [ os macosx? ] [ "cocoa" ] }
            { [ os windows? ] [ "windows" ] }
            { [ os unix? ] [ "x11" ] }
        } cond
    ] unless* "ui.backend." prepend require

    "ui-text-backend" get [
        {
            { [ os macosx? ] [ "core-text" ] }
            { [ os windows? ] [ "pango" ] }
            { [ os unix? ] [ "pango" ] }
        } cond
    ] unless* "ui.text." prepend require
] when


USING: accessors continuations destructors io.sockets io.sockets.windows
kernel sequences tools.test urls windows.winsock ;
IN: io.sockets.windows.tests

: google-socket ( -- socket )
    URL" http://www.google.com" url-addr resolve-host first
    SOCK_STREAM open-socket ;

{ } [
    { FIONBIO FIONREAD } [
        google-socket [
            swap execute( -- x )
            [ 1 set-ioctl-socket ] [ 0 set-ioctl-socket ] 2bi
        ] with-disposal
    ] each
] unit-test

{ t } [
    google-socket [
        [  1337 -8 set-ioctl-socket ]
        [ [ winsock-exception? ] [ n>> 10045 = ] bi and ] recover
    ] with-disposal
] unit-test

Fix unit test--recover leaves socket on stack, nip it.

USING: accessors continuations destructors io.sockets io.sockets.windows
kernel sequences tools.test urls windows.winsock ;
IN: io.sockets.windows.tests

: google-socket ( -- socket )
    URL" http://www.google.com" url-addr resolve-host first
    SOCK_STREAM open-socket ;

{ } [
    { FIONBIO FIONREAD } [
        google-socket [
            swap execute( -- x )
            [ 1 set-ioctl-socket ] [ 0 set-ioctl-socket ] 2bi
        ] with-disposal
    ] each
] unit-test

{ t } [
    google-socket [
        [  1337 -8 set-ioctl-socket ]
        [ nip [ winsock-exception? ] [ n>> 10045 = ] bi and ] recover
    ] with-disposal
] unit-test


USING: byte-arrays calendar kernel math memory namespaces
random threads tools.profiler.sampling
tools.profiler.sampling.private tools.test sequences ;
IN: tools.profiler.sampling.tests

! Make sure the profiler doesn't blow up the VM
TUPLE: boom ;
{ } [ 10 [ [ ] profile ] times ] unit-test
[ 10 [ [ boom new throw ] profile ] times ] [ boom? ] must-fail-with
{ } [ 10 [ [ 100 [ 1000 random (byte-array) drop ] times gc ] profile ] times ] unit-test
{ } [ 10 [ [ 100 [ 1000 random (byte-array) drop ] times compact-gc ] profile ] times ] unit-test
{ } [ 2 [ [ 1 seconds sleep ] profile ] times ] unit-test

[ ] [ [ 10 iota [ sq ] map ] profile flat profile. ] unit-test
[ ] [ [ 10 iota [ sq ] map ] profile top-down profile. ] unit-test

(clear-samples)
f raw-profile-data set-global
gc

Fix unit tests to give the sampling profiler something to profile.

USING: byte-arrays calendar kernel math memory namespaces
random threads tools.profiler.sampling
tools.profiler.sampling.private tools.test sequences ;
IN: tools.profiler.sampling.tests

! Make sure the profiler doesn't blow up the VM
TUPLE: boom ;
{ } [ 10 [ [ ] profile ] times ] unit-test
[ 10 [ [ boom new throw ] profile ] times ] [ boom? ] must-fail-with
{ } [ 10 [ [ 100 [ 1000 random (byte-array) drop ] times gc ] profile ] times ] unit-test
{ } [ 10 [ [ 100 [ 1000 random (byte-array) drop ] times compact-gc ] profile ] times ] unit-test
{ } [ 2 [ [ 1 seconds sleep ] profile ] times ] unit-test

[ ] [ [ 1,000,000 iota [ sq ] map drop ] profile flat profile. ] unit-test
[ ] [ [ 1,000,000 iota [ sq ] map drop ] profile top-down profile. ] unit-test

(clear-samples)
f raw-profile-data set-global
gc


USING: kernel alien combinators alien.syntax
       alien.c-types
       alien.libraries ;
IN: tokyo.alient.tcutil

C-ENUM:
    TCDBTHASH
    TCDBTBTREE
    TCDBTFIXED
    TCDBTTABLE ;

! long seems safe enough
TYPEDEF: long time_t

TYPEDEF: void* TCLIST*

FUNCTION: TCLIST* tclistnew ( ) ;
FUNCTION: TCLIST* tclistnew2 ( int anum ) ;
FUNCTION: void tclistdel ( TCLIST* list ) ;
FUNCTION: int tclistnum ( TCLIST* list ) ;
FUNCTION: void* tclistval ( TCLIST* list, int index, int* sp ) ;
FUNCTION: char* tclistval2 ( TCLIST* list, int index ) ;
FUNCTION: void tclistpush ( TCLIST* list, void* ptr, int size ) ;
FUNCTION: void tclistpush2 ( TCLIST* list, char* str ) ;

Make time_t a long, needs fix for 64bits windows

USING: kernel alien combinators alien.syntax
       alien.c-types
       alien.libraries ;
IN: tokyo.alient.tcutil

C-ENUM:
    TCDBTHASH
    TCDBTBTREE
    TCDBTFIXED
    TCDBTTABLE ;

! FIXME: on windows 64bits this isn't correct, because long is 32bits there, and time_t is int64
TYPEDEF: long time_t

TYPEDEF: void* TCLIST*

FUNCTION: TCLIST* tclistnew ( ) ;
FUNCTION: TCLIST* tclistnew2 ( int anum ) ;
FUNCTION: void tclistdel ( TCLIST* list ) ;
FUNCTION: int tclistnum ( TCLIST* list ) ;
FUNCTION: void* tclistval ( TCLIST* list, int index, int* sp ) ;
FUNCTION: char* tclistval2 ( TCLIST* list, int index ) ;
FUNCTION: void tclistpush ( TCLIST* list, void* ptr, int size ) ;
FUNCTION: void tclistpush2 ( TCLIST* list, char* str ) ;


IN: game-input.tests
USING: game-input tools.test kernel system ;

os windows? os macosx? or [
    [ ] [ open-game-input ] unit-test
    [ ] [ close-game-input ] unit-test
] when

Add workaround for game-input crash

IN: game-input.tests
USING: game-input tools.test kernel system threads ;

os windows? os macosx? or [
    [ ] [ open-game-input ] unit-test
    [ ] [ yield ] unit-test
    [ ] [ close-game-input ] unit-test
] when


! Copyright (C) 2017 Pi.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax help.topics strings ;
IN: unicode.control-pictures

HELP: control-pictures
{ $values
    { "string" string }
}
{ $description "Transforms C0 control characters into their corresponding Control Picture block codepoints." } ;

ARTICLE: "unicode.control-pictures" "Control Pictures"
"The " { $vocab-link "unicode.control-pictures" } " vocabulary provides a utility word " { $link control-pictures } " for transforming characters in the nonprintable ASCII C0 block to their representations in the Control Pictures block. It has no effect on any other characters."
;

ABOUT: "unicode.control-pictures"

Improve documentation by linking to Unicode charts for the relevant blocks

! Copyright (C) 2017 Pi.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables help.markup help.stylesheet help.syntax
help.topics io.styles kernel namespaces present sequences
strings urls ;
IN: unicode.control-pictures

: $url-to ( children -- )
    first2 >url [
        dup present href associate url-style get assoc-union
        [ write-object ] with-style
    ] ($span) ;

HELP: control-pictures
{ $values
    { "string" string }
}
{ $description "Transforms C0 control characters into their corresponding Control Picture block codepoints." } ;

ARTICLE: "unicode.control-pictures" "Control Pictures"
"The " { $vocab-link "unicode.control-pictures" } " vocabulary provides a utility word " { $link control-pictures } " for transforming characters in the nonprintable " { $url-to "ASCII C0 block" "http://www.unicode.org/charts/PDF/U0000.pdf" } " to their representations in the " { $url-to "Control Pictures" "http://www.unicode.org/charts/PDF/U2400.pdf" } " block. It has no effect on any other characters."
;

ABOUT: "unicode.control-pictures"


! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: lisp lisp.parser tools.test ;

IN: lisp.test

{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [
  "(foo 1 2 \"aoeu\")" lisp-string>factor
] unit-test

init-env

"+" [ first2 + ] lisp-define

{ [ first2 + ] } [
  "+" lisp-get
] unit-test

{ 3 } [
  "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
] unit-test

Fix load error in lisp

! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: lisp lisp.parser tools.test sequences math kernel ;

IN: lisp.test

{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [
  "(foo 1 2 \"aoeu\")" lisp-string>factor
] unit-test

init-env

"+" [ first2 + ] lisp-define

{ [ first2 + ] } [
  "+" lisp-get
] unit-test

{ 3 } [
  "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
] unit-test


USING: io io.pathnames kernel mason.child mason.config
namespaces sequences system tools.test ;
IN: mason.child.tests

{ { "make" "macosx-x86-32" } } [
    H{
        { target-os macosx }
        { target-cpu x86.32 }
    } [ mason-child-make-cmd ] with-variables
] unit-test

! Must be an absolute path on Windows because launch directory
! is relative to parent directory (instead of current directory).
{ t } [
    H{
        { target-os windows }
        { target-cpu x86.32 }
    } [ mason-child-make-cmd ] with-variables first absolute-path?
] unit-test

{ t } [
    H{
        { target-os windows }
        { target-cpu x86.32 }
    } [ mason-child-boot-cmd ] with-variables first absolute-path?
] unit-test

[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer

{ 4 } [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test

{ 3 } [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test

{ "A" } [
    {
        { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] }
        [ "B" ]
    } recover-cond
] unit-test

{ "B" } [
    {
        { [ ] [ ] }
        [ "B" ]
    } recover-cond
] unit-test

Remove unit tests since they're hard to maintain and if they fail then the CI fails as well anyway.

USING: io io.pathnames kernel mason.child mason.config
namespaces sequences system tools.test ;
IN: mason.child.tests

{ t } [
    H{
        { target-os windows }
        { target-cpu x86.32 }
    } [ mason-child-boot-cmd ] with-variables first absolute-path?
] unit-test

[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer

{ 4 } [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test

{ 3 } [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test

{ "A" } [
    {
        { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] }
        [ "B" ]
    } recover-cond
] unit-test

{ "B" } [
    {
        { [ ] [ ] }
        [ "B" ]
    } recover-cond
] unit-test


USING: accessors sequences tools.test ui.gadgets
ui.gadgets.labeled ;
IN: ui.gadgets.labeled.tests

{ t } [
    <gadget> "Hey" <labeled-gadget>
    children>> first content>> gadget?
] unit-test

Fix a random failing unit test.

USING: accessors colors.constants sequences tools.test
ui.gadgets ui.gadgets.labeled ;
IN: ui.gadgets.labeled.tests

{ t } [
    <gadget> "Hey" COLOR: blue <labeled-gadget>
    content>> gadget?
] unit-test


USING: tools.deploy.config ;
H{
    { deploy-name "Hello world (console)" }
    { deploy-c-types? f }
    { deploy-word-props? f }
    { deploy-ui? f }
    { deploy-reflection 1 }
    { deploy-compiler? f }
    { deploy-unicode? f }
    { deploy-io 2 }
    { deploy-word-defs? f }
    { deploy-threads? f }
    { "stop-after-last-window?" t }
    { deploy-math? f }
}

Deploy hello-world with optimizing compiler since the image is smaller as a result, and this makes it pass the size test again

USING: tools.deploy.config ;
H{
    { deploy-unicode? f }
    { deploy-ui? f }
    { deploy-compiler? t }
    { deploy-name "Hello world (console)" }
    { deploy-io 2 }
    { deploy-threads? f }
    { deploy-reflection 1 }
    { deploy-math? f }
    { deploy-word-props? f }
    { deploy-word-defs? f }
    { deploy-c-types? f }
    { "stop-after-last-window?" t }
}


! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.strings cuda cuda.syntax destructors
io.encodings.utf8 kernel locals math prettyprint sequences ;
IN: cuda.hello-world

CUDA-LIBRARY: hello vocab:cuda/hello.ptx

CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;

:: cuda-hello-world ( -- )
    T{ launcher
        { device 0 }
        { path "vocab:cuda/hello.ptx" }
    } [
        "Hello World!" [ - ] map-index malloc-device-string &dispose dup :> str

        T{ function-launcher
            { dim-block { 6 1 1 } }
            { dim-grid { 2 1 } }
            { shared-size 0 }
        }
        helloWorld

        ! <<< { 6 1 1 } { 2 1 } 1 >>> helloWorld

        str device>host utf8 alien>string .
    ] with-cuda ;

MAIN: cuda-hello-world

Fix the ptx path in cuda demo

! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.strings cuda cuda.syntax destructors
io.encodings.utf8 kernel locals math prettyprint sequences ;
IN: cuda.demos.hello-world

CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx

CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;

:: cuda-hello-world ( -- )
    T{ launcher
        { device 0 }
        { path "vocab:cuda/demos/hello-world/hello.ptx" }
    } [
        "Hello World!" [ - ] map-index malloc-device-string &dispose dup :> str

        T{ function-launcher
            { dim-block { 6 1 1 } }
            { dim-grid { 2 1 } }
            { shared-size 0 }
        }
        helloWorld

        ! <<< { 6 1 1 } { 2 1 } 1 >>> helloWorld

        str device>host utf8 alien>string .
    ] with-cuda ;

MAIN: cuda-hello-world


IN: advice
USING: help.markup help.syntax tools.annotations words ;

HELP: make-advised
{ $values { "word" "a word to annotate in preparation of advising" } }
{ $description "Prepares a word for being advised.  This is done by: "
    { $list
        { "Annotating it to call the appropriate words before, around, and after the original body " }
        { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
        { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
    }
}
{ $see-also advised? annotate } ;

HELP: advised?
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet word } " is advised" } }
{ $description "Determines whether or not the given word has any advice on it." } ;

ARTICLE: "advice" "Advice"
"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;

ABOUT: "advice"

Fix markup problem detected by help-lint

IN: advice
USING: help.markup help.syntax tools.annotations words ;

HELP: make-advised
{ $values { "word" "a word to annotate in preparation of advising" } }
{ $description "Prepares a word for being advised.  This is done by: "
    { $list
        { "Annotating it to call the appropriate words before, around, and after the original body " }
        { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
        { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
    }
}
{ $see-also advised? annotate } ;

HELP: advised?
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
{ $description "Determines whether or not the given word has any advice on it." } ;

ARTICLE: "advice" "Advice"
"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;

ABOUT: "advice"


! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax byte-arrays strings ;
IN: io.encodings.string

ARTICLE: "io.encodings.string" "Encoding and decoding strings"
"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
{ $link "encodings-descriptors" } " to the following words:"
{ $subsections
    encode
    decode
} ;

HELP: decode
{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" }
    { "string" string } }
{ $description "Decodes the byte array using the given encoding, outputting a string" } ;

HELP: encode
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Encodes the given string into a byte array with the given encoding." } ;

Add examples to encode/decode docs.

! Copyright (C) 2008,2011 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays help.markup help.syntax io.encodings.string
strings ;
IN: io.encodings.string

ARTICLE: "io.encodings.string" "Encoding and decoding strings"
"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
{ $link "encodings-descriptors" } " to the following words:"
{ $subsections
    encode
    decode
} ;

HELP: decode
{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" }
    { "string" string } }
{ $description "Converts an array of bytes to a string, interpreting that array of bytes as a string with the given encoding." }
{ $examples
    { $example """USING: io.encodings.string io.encodings.utf8 prettyprint ;
B{ 230 136 145 231 136 177 228 189 160 } utf8 decode ."""
""""我爱你""""
    }
} ;

HELP: encode
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Converts a string into a byte array, interpreting that string with the given encoding." }
{ $examples
    { $example """USING: io.encodings.string io.encodings.utf8 prettyprint ;
"我爱你" utf8 encode ."""
"B{ 230 136 145 231 136 177 228 189 160 }"
    }
} ;


USING: combinators.smart io.directories
io.directories.hierarchy io.directories.search io.files
io.files.unique io.pathnames kernel namespaces sequences
sorting strings tools.test ;
IN: io.directories.search.tests

[ t ] [
    [
        10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
        current-temporary-directory get [ ] find-all-files
    ] cleanup-unique-directory [ natural-sort ] same?
] unit-test

[ f ] [
    { "omg you shoudnt have a directory called this" "or this" }
    t
    [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
] unit-test

[ f ] [
    { } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
] unit-test

[ t ] [
    [
        current-temporary-directory get
        "the-head" unique-file drop t
        [ file-name "the-head" head? ] find-file string?
    ] cleanup-unique-directory
] unit-test

[ t ] [
    [ unique-directory unique-directory ] output>array
    [ [ "abcd" append-path touch-file ] each ]
    [ [ file-name "abcd" = ] find-all-in-directories length 2 = ]
    [ [ delete-tree ] each ] tri
] unit-test

Add two tests for find-up-to-directory, one that finds a file and one that doesn't.

USING: combinators.smart io.directories
io.directories.hierarchy io.directories.search io.files
io.files.unique io.pathnames kernel namespaces sequences
sorting strings tools.test ;
IN: io.directories.search.tests

[ t ] [
    [
        10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
        current-temporary-directory get [ ] find-all-files
    ] cleanup-unique-directory [ natural-sort ] same?
] unit-test

[ f ] [
    { "omg you shoudnt have a directory called this" "or this" }
    t
    [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
] unit-test

[ f ] [
    { } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
] unit-test

[ t ] [
    [
        current-temporary-directory get
        "the-head" unique-file drop t
        [ file-name "the-head" head? ] find-file string?
    ] cleanup-unique-directory
] unit-test

[ t ] [
    [ unique-directory unique-directory ] output>array
    [ [ "abcd" append-path touch-file ] each ]
    [ [ file-name "abcd" = ] find-all-in-directories length 2 = ]
    [ [ delete-tree ] each ] tri
] unit-test

{ t } [
    "resource:core/math/integers/integers.factor"
    [ "math.factor" tail? ] find-up-to-root >boolean
] unit-test

{ f } [
    "resource:core/math/integers/integers.factor"
    [ drop f ] find-up-to-root
] unit-test


! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private kernel words classes
math alien alien.c-types byte-arrays accessors
specialized-arrays ;
IN: specialized-arrays.direct.functor

FUNCTOR: define-direct-array ( T -- )

A'      IS ${T}-array
>A'     IS >${T}-array
<A'>    IS <${A'}>

A       DEFINES direct-${T}-array
<A>     DEFINES <${A}>

NTH     [ T dup c-getter array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]

WHERE

TUPLE: A
{ underlying alien read-only }
{ length fixnum read-only } ;

: <A> ( alien len -- direct-array ) A boa ; inline
M: A length length>> ;
M: A nth-unsafe underlying>> NTH call ;
M: A set-nth-unsafe underlying>> SET-NTH call ;
M: A like drop dup A instance? [ >A' execute ] unless ;
M: A new-sequence drop <A'> execute ;

INSTANCE: A sequence

;FUNCTOR

Generalize specialized-arrays.direct: it should be able to wrap a byte array

! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private kernel words classes
math alien alien.c-types byte-arrays accessors
specialized-arrays ;
IN: specialized-arrays.direct.functor

FUNCTOR: define-direct-array ( T -- )

A'      IS ${T}-array
>A'     IS >${T}-array
<A'>    IS <${A'}>

A       DEFINES direct-${T}-array
<A>     DEFINES <${A}>

NTH     [ T dup c-getter array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]

WHERE

TUPLE: A
{ underlying c-ptr read-only }
{ length fixnum read-only } ;

: <A> ( alien len -- direct-array ) A boa ; inline
M: A length length>> ;
M: A nth-unsafe underlying>> NTH call ;
M: A set-nth-unsafe underlying>> SET-NTH call ;
M: A like drop dup A instance? [ >A' execute ] unless ;
M: A new-sequence drop <A'> execute ;

INSTANCE: A sequence

;FUNCTOR


USING: accessors tools.test ui.gadgets ui.gadgets.labels ;
IN: ui.gadgets.labels.tests

[ { 119 14 } ] [
    <gadget> { 100 14 } >>dim
    <gadget> { 14 14 } >>dim
    label-on-right { 5 5 } >>gap
    pref-dim
] unit-test


USING: kernel math tools.test namespaces random
random.blum-blum-shub alien.c-types sequences splitting
grouping ;
IN: blum-blum-shub.tests

[ 887708070 ] [
    T{ blum-blum-shub f 590695557939 811977232793 } clone random-32*
] unit-test

[ 70576473 ] [
    T{ blum-blum-shub f 590695557939 811977232793 } clone [
        32 random-bits
    ] with-random
] unit-test

[ 5570804936418322777 ] [
    T{ blum-blum-shub f 590695557939 811977232793 } clone [
        64 random-bits
    ] with-random
] unit-test

[ 3716213681 ]
[
    T{ blum-blum-shub f 200352954495 846054538649 } clone 100 over [
        random-32* drop
    ] curry times
    random-32*
] unit-test

Fix test failure for random number speedup from using be>.

USING: kernel math tools.test namespaces random
random.blum-blum-shub alien.c-types sequences splitting
grouping ;
IN: blum-blum-shub.tests

[ 887708070 ] [
    T{ blum-blum-shub f 590695557939 811977232793 } clone random-32*
] unit-test

[ 2790910260 ] [
    T{ blum-blum-shub f 590695557939 811977232793 } clone [
        32 random-bits
    ] with-random
] unit-test

[ 11986868292847630671 ] [
    T{ blum-blum-shub f 590695557939 811977232793 } clone [
        64 random-bits
    ] with-random
] unit-test

[ 3716213681 ]
[
    T{ blum-blum-shub f 200352954495 846054538649 } clone 100 over [
        random-32* drop
    ] curry times
    random-32*
] unit-test


Add unit test for xmode bug discovered by anonymous pastebin user

IN: xmode.code2html.tests
USING: xmode.code2html xmode.catalog
tools.test multiline splitting memoize
kernel ;

[ ] [ \ (load-mode) reset-memoized ] unit-test

[ ] [
    <" <style type="text/css" media="screen" >
    *        {margin:0; padding:0; border:0;} ">
    string-lines "html" htmlize-lines drop
] unit-test


! Copyright (C) 2008 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel arrays math accessors sequences
math.vectors math.order sorting binary-search sets assocs fry ;
IN: suffix-arrays

<PRIVATE

: suffixes ( string -- suffixes-seq )
    dup length iota [ tail-slice ] with map ;

: prefix<=> ( begin seq -- <=> )
    [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;

: find-index ( begin suffix-array -- index/f )
    [ prefix<=> ] with search drop ;

: from-to ( index begin suffix-array -- from/f to/f )
    swap '[ _ head? not ]
    [ find-last-from drop dup [ 1 + ] when ]
    [ find-from drop ] 3bi ;

: <funky-slice> ( from/f to/f seq -- slice )
    [
        [ drop 0 or ] [ length or ] bi-curry bi*
        [ min ] keep
    ] keep <slice> ; inline

PRIVATE>

: >suffix-array ( seq -- array )
    [ suffixes ] map concat natural-sort ;

SYNTAX: SA{ \ } [ >suffix-array ] parse-literal ;

: query ( begin suffix-array -- matches )
    2dup find-index dup
    [ -rot [ from-to ] keep <funky-slice> [ seq>> ] map members ]
    [ 3drop { } ] if ;

Make suffix arrays prune repeated members before construction

! Copyright (C) 2008 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel arrays math accessors sequences
math.vectors math.order sorting binary-search sets assocs fry ;
IN: suffix-arrays

<PRIVATE

: suffixes ( string -- suffixes-seq )
    dup length iota [ tail-slice ] with map ;

: prefix<=> ( begin seq -- <=> )
    [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;

: find-index ( begin suffix-array -- index/f )
    [ prefix<=> ] with search drop ;

: from-to ( index begin suffix-array -- from/f to/f )
    swap '[ _ head? not ]
    [ find-last-from drop dup [ 1 + ] when ]
    [ find-from drop ] 3bi ;

: <funky-slice> ( from/f to/f seq -- slice )
    [
        [ drop 0 or ] [ length or ] bi-curry bi*
        [ min ] keep
    ] keep <slice> ; inline

PRIVATE>

: >suffix-array ( seq -- array )
    members
    [ suffixes ] map concat natural-sort ;

SYNTAX: SA{ \ } [ >suffix-array ] parse-literal ;

: query ( begin suffix-array -- matches )
    2dup find-index dup
    [ -rot [ from-to ] keep <funky-slice> [ seq>> ] map members ]
    [ 3drop { } ] if ;


! Copyright (C) 2009 Nicholas Seckar.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations eval fuel fuel.private namespaces tools.test words ;
IN: fuel.tests

: fake-continuation ( -- continuation )
    f f f "fake" f <continuation> ;

: make-uses-restart ( -- restart )
    "Use the words vocabulary" \ word?
    fake-continuation <restart> ;

: make-defer-restart ( -- restart )
    "Defer word in current vocabulary" f
    fake-continuation <restart> ;

{ f } [ make-defer-restart is-use-restart ] unit-test
{ t } [ make-uses-restart is-use-restart ] unit-test

{ "words" } [ make-uses-restart get-restart-vocab ] unit-test

{ f } [ make-defer-restart is-suggested-restart ] unit-test
{ f } [ make-uses-restart is-suggested-restart ] unit-test
{ f } [ { "io" } :uses-suggestions
        [ make-uses-restart is-suggested-restart ] with-variable
] unit-test
{ t } [ { "words" } :uses-suggestions
        [ make-uses-restart is-suggested-restart ] with-variable
] unit-test

{ } [
    { "kernel" } [ "\\ dup drop" eval( -- ) ] fuel-use-suggested-vocabs
] unit-test


! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
IN: openal.other
USING: openal alien.c-types kernel alien alien.syntax shuffle combinators.lib ;

LIBRARY: alut

FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;

M: other-openal-impl load-wav-file ( filename -- format data size frequency )
  0 <int> f <void*> 0 <int> 0 <int>
  [ 0 <char> alutLoadWAVFile ] 4keep
  >r >r >r *int r> *void* r> *int r> *int ;

Fix openal loading on non-mac platforms

! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
IN: openal.other
USING: openal.backend alien.c-types kernel alien alien.syntax shuffle combinators.lib ;

LIBRARY: alut

FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;

M: other-openal-backend load-wav-file ( filename -- format data size frequency )
  0 <int> f <void*> 0 <int> 0 <int>
  [ 0 <char> alutLoadWAVFile ] 4keep
  >r >r >r *int r> *void* r> *int r> *int ;


IN: macros.expander.tests
USING: macros.expander tools.test math combinators.short-circuit
kernel ;

[ t ] [ 20 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test

[ f ] [ 15 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test

[ f ] [ 5.0 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test

[ [ no-case ] ] [ [ { } case ] expand-macros ] unit-test

Fix unit test for macros.expander

IN: macros.expander.tests
USING: macros.expander tools.test math combinators.short-circuit
kernel combinators ;

[ t ] [ 20 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test

[ f ] [ 15 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test

[ f ] [ 5.0 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test

[ [ no-case ] ] [ [ { } case ] expand-macros ] unit-test


! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.linux
USING: io.backend io.unix.backend io.unix.launcher io.unix.select
namespaces kernel assocs unix.process ;

TUPLE: linux-io ;

INSTANCE: linux-io unix-io

M: linux-io init-io ( -- )
    <select-mx> mx set-global
    start-wait-thread ;

T{ linux-io } set-io-backend

Fix wait loop bug (fixed by Slava)

! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.linux
USING: io.backend io.unix.backend io.unix.launcher io.unix.select
namespaces kernel assocs unix.process init ;

TUPLE: linux-io ;

INSTANCE: linux-io unix-io

M: linux-io init-io ( -- )
    <select-mx> mx set-global ;

T{ linux-io } set-io-backend

[ start-wait-thread ] "io.unix.linux" add-init-hook


USING: graphics.bitmap ;
IN: graphics.bitmap.tests

: test-bitmap24 ( -- )
    "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;

: test-bitmap8 ( -- )
    "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;

: test-bitmap4 ( -- )
    "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;

: test-bitmap1 ( -- )
    "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;

Fix load error in graphics.bitmap tests

USING: graphics.bitmap graphics.viewer ;
IN: graphics.bitmap.tests

: test-bitmap24 ( -- )
    "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;

: test-bitmap8 ( -- )
    "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;

: test-bitmap4 ( -- )
    "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;

: test-bitmap1 ( -- )
    "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;


USING: oauth oauth.private tools.test accessors kernel assocs
strings namespaces ;
IN: oauth.tests

[ "%26&b" ] [ "&" "b" hmac-key ] unit-test
[ "%26&" ] [ "&" f hmac-key ] unit-test

[ "B&http%3A%2F%2Ftwitter.com&a%3Db" ] [
    "http://twitter.com"
    "B"
    { { "a" "b" } }
    signature-base-string
] unit-test

[ "Z5tUa83q43qiy6dGGCb92bN/4ik=" ] [
    "ABC" "DEF" <token> consumer-token set

    "http://twitter.com"
    <request-token-params>
        12345 >>timestamp
        54321 >>nonce
    <request-token-request>
    post-data>>
    "oauth_signature" of
    >string
] unit-test

Fix tests. Twitter API tolerates the extra ``/`` at the end of ``twitter.com``, so leave it in.

USING: oauth oauth.private tools.test accessors kernel assocs
strings namespaces urls ;
IN: oauth.tests

[ "%26&b" ] [ "&" "b" hmac-key ] unit-test
[ "%26&" ] [ "&" f hmac-key ] unit-test

[ "B&http%3A%2F%2Ftwitter.com%2F&a%3Db" ] [
    URL" http://twitter.com"
    "B"
    { { "a" "b" } }
    signature-base-string
] unit-test

[ "0EieqbHx0FJ/RtFskmRj9/TDpqo=" ] [
    "ABC" "DEF" <token> consumer-token set

    URL" http://twitter.com"
    <request-token-params>
        12345 >>timestamp
        54321 >>nonce
    <request-token-request>
    post-data>>
    "oauth_signature" of
    >string
] unit-test


! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs environment fry
io.directories.search.windows io.files io.pathnames
io.standard-paths kernel sequences splitting system
unicode.case ;
IN: io.standard-paths.windows

M: windows find-in-applications
    '[ [ >lower _ tail? ] find-in-program-files ] map-find drop ;

: path ( -- path )
    "PATH" os-env ";" split "." prefix ;

: path-extensions ( command -- commands )
    "PATHEXT" os-env [
        ";" split 2dup [ [ >lower ] bi@ tail? ] with any?
        [ drop 1array ] [ [ append ] with map ] if
    ] [ 1array ] if* ;

M: windows find-in-path*
    path-extensions path
    cartesian-product flip concat
    [ prepend-path ] { } assoc>map
    [ exists? ] find nip ;

Revert "io.standard-paths: adding support for PATHEXT."

! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: environment fry io.directories.search.windows io.files
io.pathnames io.standard-paths kernel sequences splitting
system unicode.case ;
IN: io.standard-paths.windows

M: windows find-in-applications
    '[ [ >lower _ tail? ] find-in-program-files ] map-find drop ;

M: windows find-in-path*
    [ "PATH" os-env ";" split ] dip
    '[ _ append-path exists? ] find nip ;


! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences db.tuples alarms calendar db fry
furnace.db
furnace.cache
furnace.asides
furnace.referrer
furnace.sessions
furnace.conversations
furnace.auth.providers
furnace.auth.login.permits ;
IN: furnace.alloy

: state-classes { session aside conversation permit } ; inline

: init-furnace-tables ( -- )
    state-classes ensure-tables
    user ensure-table ;

: <alloy> ( responder db -- responder' )
    [ [ init-furnace-tables ] with-db ] keep
    [
        <asides>
        <conversations>
        <sessions>
    ] dip
    <db-persistence>
    <check-form-submissions> ;

: start-expiring ( db -- )
    '[
        _ [ state-classes [ expire-state ] each ] with-db
    ] 5 minutes every drop ;

Disable referrer checking by default since adblock doesn't send it for some lame reason

! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences db.tuples alarms calendar db fry
furnace.db
furnace.cache
furnace.asides
furnace.sessions
furnace.conversations
furnace.auth.providers
furnace.auth.login.permits ;
IN: furnace.alloy

: state-classes { session aside conversation permit } ; inline

: init-furnace-tables ( -- )
    state-classes ensure-tables
    user ensure-table ;

: <alloy> ( responder db -- responder' )
    [ [ init-furnace-tables ] with-db ] keep
    [
        <asides>
        <conversations>
        <sessions>
    ] dip
    <db-persistence> ;

: start-expiring ( db -- )
    '[
        _ [ state-classes [ expire-state ] each ] with-db
    ] 5 minutes every drop ;


USE: specialized-arrays.functor
IN: specialized-arrays.double

<< "double" define-array >>

Add specialization hints from old float-arrays. These will be replaced with a better facility soon

USE: specialized-arrays.functor
IN: specialized-arrays.double

<< "double" define-array >>

! Specializer hints. These should really be generalized, and placed
! somewhere else
USING: hints math.vectors arrays kernel math accessors sequences ;

HINTS: <double-array> { 2 } { 3 } ;

HINTS: vneg { array } { double-array } ;
HINTS: v*n { array object } { double-array float } ;
HINTS: n*v { array object } { float double-array } ;
HINTS: v/n { array object } { double-array float } ;
HINTS: n/v { object array } { float double-array } ;
HINTS: v+ { array array } { double-array double-array } ;
HINTS: v- { array array } { double-array double-array } ;
HINTS: v* { array array } { double-array double-array } ;
HINTS: v/ { array array } { double-array double-array } ;
HINTS: vmax { array array } { double-array double-array } ;
HINTS: vmin { array array } { double-array double-array } ;
HINTS: v. { array array } { double-array double-array } ;
HINTS: norm-sq { array } { double-array } ;
HINTS: norm { array } { double-array } ;
HINTS: normalize { array } { double-array } ;
HINTS: distance { array array } { double-array double-array } ;

! Type functions
USING: words classes.algebra compiler.tree.propagation.info
math.intervals ;

{ v+ v- v* v/ vmax vmin } [
    [
        [ class>> double-array class<= ] both?
        double-array object ? <class-info>
    ] "outputs" set-word-prop
] each

{ n*v n/v } [
    [
        nip class>> double-array class<= double-array object ? <class-info>
    ] "outputs" set-word-prop
] each

{ v*n v/n } [
    [
        drop class>> double-array class<= double-array object ? <class-info>
    ] "outputs" set-word-prop
] each

{ vneg normalize } [
    [
        class>> double-array class<= double-array object ? <class-info>
    ] "outputs" set-word-prop
] each

\ norm-sq [
    class>> double-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
] "outputs" set-word-prop

\ v. [
    [ class>> double-array class<= ] both?
    float object ? <class-info>
] "outputs" set-word-prop

\ distance [
    [ class>> double-array class<= ] both?
    [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
] "outputs" set-word-prop


USING: tools.deploy.config ;
H{
    { deploy-name "Hello world (console)" }
    { deploy-c-types? f }
    { deploy-word-props? f }
    { deploy-ui? f }
    { deploy-reflection 1 }
    { deploy-compiler? f }
    { deploy-unicode? f }
    { deploy-io 2 }
    { deploy-word-defs? f }
    { deploy-threads? f }
    { "stop-after-last-window?" t }
    { deploy-math? f }
}

Deploy hello-world with optimizing compiler since the image is smaller as a result, and this makes it pass the size test again

USING: tools.deploy.config ;
H{
    { deploy-unicode? f }
    { deploy-ui? f }
    { deploy-compiler? t }
    { deploy-name "Hello world (console)" }
    { deploy-io 2 }
    { deploy-threads? f }
    { deploy-reflection 1 }
    { deploy-math? f }
    { deploy-word-props? f }
    { deploy-word-defs? f }
    { deploy-c-types? f }
    { "stop-after-last-window?" t }
}


USING: classes.singleton io.streams.string kernel see tools.test ;
IN: classes.singleton.tests

{ } [ SINGLETON: bzzt ] unit-test
{ t } [ bzzt bzzt? ] unit-test
{ t } [ bzzt bzzt eq? ] unit-test
GENERIC: zammo ( obj -- str )
{ } [ M: bzzt zammo drop "yes!" ; ] unit-test
{ "yes!" } [ bzzt zammo ] unit-test
{ } [ SINGLETON: omg ] unit-test
{ t } [ omg singleton-class? ] unit-test
{ "IN: classes.singleton.tests\nSINGLETON: omg\n" } [ [ omg see ] with-string-writer ] unit-test

SINGLETON: word-and-singleton

: word-and-singleton ( -- x ) 3 ;

{ t } [ \ word-and-singleton word-and-singleton? ] unit-test
{ 3 } [ word-and-singleton ] unit-test

Move definitions to top level in tests.

USING: classes.singleton io.streams.string kernel see tools.test ;
IN: classes.singleton.tests

SINGLETON: bzzt
{ t } [ bzzt bzzt? ] unit-test
{ t } [ bzzt bzzt eq? ] unit-test

GENERIC: zammo ( obj -- str )
{ } [ M: bzzt zammo drop "yes!" ; ] unit-test
{ "yes!" } [ bzzt zammo ] unit-test

SINGLETON: omg
{ t } [ omg singleton-class? ] unit-test
{ "IN: classes.singleton.tests\nSINGLETON: omg\n" } [ [ omg see ] with-string-writer ] unit-test

SINGLETON: word-and-singleton

: word-and-singleton ( -- x ) 3 ;

{ t } [ \ word-and-singleton word-and-singleton? ] unit-test
{ 3 } [ word-and-singleton ] unit-test


! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors destructors accessors kernel parser words ;
IN: alien.destructors

FUNCTOR: define-destructor ( F -- )

F-destructor DEFINES ${F}-destructor
<F-destructor> DEFINES <${F}-destructor>
&F DEFINES &${F}
|F DEFINES |${F}

WHERE

TUPLE: F-destructor alien disposed ;

: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline

M: F-destructor dispose* alien>> F execute ;

: &F ( alien -- alien ) dup <F-destructor> execute &dispose drop ; inline

: |F ( alien -- alien ) dup <F-destructor> execute |dispose drop ; inline

;FUNCTOR

: DESTRUCTOR: scan-word define-destructor ; parsing

Fix bootstrap by adding protocol slot

! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors destructors accessors kernel parser words ;
IN: alien.destructors

SLOT: alien

FUNCTOR: define-destructor ( F -- )

F-destructor DEFINES ${F}-destructor
<F-destructor> DEFINES <${F}-destructor>
&F DEFINES &${F}
|F DEFINES |${F}

WHERE

TUPLE: F-destructor alien disposed ;

: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline

M: F-destructor dispose* alien>> F execute ;

: &F ( alien -- alien ) dup <F-destructor> execute &dispose drop ; inline

: |F ( alien -- alien ) dup <F-destructor> execute |dispose drop ; inline

;FUNCTOR

: DESTRUCTOR: scan-word define-destructor ; parsing


IN: unix.ffi.tests
USING: accessors alien.c-types tools.test unix.ffi ;

[ 80 ] [ "http" f getservbyname port>> ntohs ] unit-test

[ "www" ] [
    0 "http" f getservbyname aliases>> c-string alien-element
] unit-test

[ "http" ] [ 80 htons f getservbyport name>> ] unit-test

Use a utility word for getting the aliases back.

USING: accessors alien.c-types io.encodings.utf8 kernel
sequences tools.test unix.ffi unix.utilities ;
IN: unix.ffi.tests

[ 80 ] [ "http" f getservbyname port>> ntohs ] unit-test

[ t ] [
    0 "http" f getservbyname aliases>> utf8 alien>strings
    "www" swap member?
] unit-test

[ "http" ] [ 80 htons f getservbyport name>> ] unit-test