.dir-locals.el

@@ -0,0 +1,14 @@
+;; Per-directory local variables for GNU Emacs 23 and later.
+((c++-mode . ((c-basic-offset . 2)
+              (show-trailing-whitespace . t)
+              (indicate-empty-lines . t)
+              (indent-tabs-mode . nil)
+              (eval . (progn
+                        (c-set-offset 'innamespace 0)
+                        (c-set-offset 'topmost-intro 0)
+                        (c-set-offset 'cpp-macro-cont '++)
+                        (c-set-offset 'case-label '+)
+                        (c-set-offset 'member-init-intro '++)
+                        (c-set-offset 'statement-cont '++)
+                        (c-set-offset 'arglist-intro '++)))))
+ (factor-mode . ((factor-block-offset . 4))))

.gitattributes

@@ -0,0 +1,3 @@
+*.factor text eol=lf
+*.html text eol=lf
+misc/vim/*/*/generated.vim linguist-generated

.gitignore

@@ -0,0 +1,34 @@
+*#*#
+*.*.marks
+*.RES
+*.a
+*.bak
+*.dll
+*.dylib
+*.exe
+*.exp
+*.gch*
+*.image
+*.lib
+*.o
+*.obj
+*.res
+*.s
+*.so
+*~
+.#*
+.*.swm
+.*.swn
+.*.swo
+.*.swp
+.DS_Store
+.gdb_history
+/factor
+/logs
+/work
+Factor.app/Contents/MacOS/factor
+Factor.app/Contents/_CodeSignature
+a.out
+checksums.txt
+factor.com
+factor.image.fresh

.travis.yml

@@ -0,0 +1,81 @@
+language: cpp
+compiler:
+  - clang
+  - gcc
+os:
+  - linux
+  - osx
+sudo: required
+dist: trusty
+group: deprecated-2017Q4
+services:
+  - postgresql
+  - redis-server
+branches:
+  except:
+  - clean-windows-x86-64
+  - clean-windows-x86-32
+  - clean-linux-x86-64
+  - clean-linux-x86-32
+  - clean-macosx-x86-64
+  - clean-macosx-x86-32
+addons:
+  apt:
+    packages:
+      - links
+      - libblas-dev
+      - libmagic-dev
+      - libsnappy-dev
+      - libzmq-dev
+      - libpq-dev
+      - cmake
+      - libaio-dev
+      - libsnappy-dev
+      - libgtk2.0-dev
+      - gtk2-engines-pixbuf
+before_install:
+  - uname -s
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then export HOMEBREW_NO_AUTO_UPDATE=1 ; fi # Don't let homebrew upgrade itself
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rm -rf ~/.gnupg/; fi  # https://github.com/rvm/rvm/issues/3110
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/mpapis.asc | gpg --import - ; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/pkuczynski.asc | gpg --import - ; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi  # https://github.com/travis-ci/travis-ci/issues/6307
+  #- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm reload ; fi # for homebrew to have 2.6.3, which takes too long. instead we just use HOMEBREW_NO_AUTO_UPDATE=1
+  #- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm install ruby-2.6.3 ; fi # for homebrew
+  #- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm use 2.6 ; fi # for homebrew
+
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions cmake > /dev/null || brew install cmake; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions libmagic > /dev/null || brew install libmagic; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions memcached > /dev/null || brew install memcached; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions redis > /dev/null || brew install redis; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions zeromq > /dev/null || brew install zeromq; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions postgresql > /dev/null || brew install postgresql; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start memcached; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start redis; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start postgresql; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start memcached; fi
+  - if [[ "$TRAVIS_OS_NAME" != "windows" ]]; then
+      wget https://github.com/vmt/udis86/archive/v1.7.2.tar.gz && tar xzvf v1.7.2.tar.gz &&
+      ( cd udis86-1.7.2/ && ./autogen.sh && ./configure --enable-shared=yes && make && sudo make install ) &&
+      ( [[ "$TRAVIS_OS_NAME" != "osx" ]] && sudo ldconfig || true );
+    fi
+  - git remote set-branches --add origin master
+  - git remote set-branches --add origin clean-windows-x86-64
+  - git remote set-branches --add origin clean-windows-x86-32
+  - git remote set-branches --add origin clean-linux-x86-64
+  - git remote set-branches --add origin clean-linux-x86-32
+  - git remote set-branches --add origin clean-macosx-x86-64
+  - git remote set-branches --add origin clean-macosx-x86-32
+  - git fetch # so we can see which vocabs changed versus origin/master...
+script:
+  - echo "TRAVIS_BRANCH=$TRAVIS_BRANCH, TRAVIS_PULL_REQUEST_BRANCH=$TRAVIS_PULL_REQUEST_BRANCH"
+  - export CI_BRANCH="${TRAVIS_PULL_REQUEST_BRANCH:-$TRAVIS_BRANCH}"
+  - echo "CI_BRANCH=${CI_BRANCH}"
+  - DEBUG=1 ./build.sh net-bootstrap < /dev/null
+  - "./factor -e='USING: memory vocabs.hierarchy tools.test namespaces ; \"zealot\" load f long-unit-tests-enabled? set-global save'"
+  - './factor -run=zealot.cli-changed-vocabs'
+  - './factor -run=tools.test `./factor -run=zealot.cli-changed-vocabs | paste -s -d " " -`'
+  - './factor -run=zealot.help-lint `./factor -run=zealot.cli-changed-vocabs | paste -s -d " " -`'
+  - "./factor -e='USING: modern.paths tools.test sequences system kernel math random ; core-vocabs os macosx? [ dup length 3 /i sample ] when [ test ] each'"

Factor.app/Contents/Info.plist

@@ -2,16 +2,6 @@
 <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
 <plist version="1.0">
 <dict>
-	<key>CFBundleExecutable</key>
-	<string>Factor</string>
-	<key>CFBundleIdentifier</key>
-	<string>org.factorcode.Factor</string>
-	<key>CFBundleInfoDictionaryVersion</key>
-	<string>6.0</string>
-	<key>CFBundleName</key>
-	<string>Factor</string>
-	<key>CFBundlePackageType</key>
-	<string>APPL</string>
 	<key>CFBundleDocumentTypes</key>
 	<array>
 		<dict>
@@ -21,14 +11,30 @@
 			</array>
 			<key>CFBundleTypeName</key>
 			<string>Any</string>
-			<key>CFBundleTypeRole</key>
-			<string>Viewer</string>
 			<key>CFBundleTypeOSTypes</key>
 			<array>
 				<string>****</string>
 			</array>
+			<key>CFBundleTypeRole</key>
+			<string>Viewer</string>
 		</dict>
 	</array>
+	<key>CFBundleExecutable</key>
+	<string>factor</string>
+	<key>CFBundleIconFile</key>
+	<string>Factor.icns</string>
+	<key>CFBundleIdentifier</key>
+	<string>org.factorcode.Factor</string>
+	<key>CFBundleInfoDictionaryVersion</key>
+	<string>6.0</string>
+	<key>CFBundleName</key>
+	<string>Factor</string>
+	<key>CFBundlePackageType</key>
+	<string>APPL</string>
+	<key>CFBundleVersion</key>
+	<string>0.99</string>
+	<key>NSHumanReadableCopyright</key>
+	<string>Copyright © 2003-2018 Factor developers</string>
 	<key>NSServices</key>
 	<array>
 		<dict>
@@ -56,15 +62,17 @@
 			<string>evalToString</string>
 			<key>NSPortName</key>
 			<string>Factor</string>
-			<key>NSSendTypes</key>
+			<key>NSReturnTypes</key>
 			<array>
 				<string>NSStringPboardType</string>
 			</array>
-			<key>NSReturnTypes</key>
+			<key>NSSendTypes</key>
 			<array>
 				<string>NSStringPboardType</string>
 			</array>
 		</dict>
 	</array>
+	<key>NSHighResolutionCapable</key>
+	<true/>
 </dict>
 </plist>

Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib

@@ -1,17 +0,0 @@
-{
-    IBClasses = (
-        {
-            ACTIONS = {
-                newFactorWorkspace = id; 
-                runFactorFile = id; 
-                saveFactorImage = id; 
-                saveFactorImageAs = id; 
-                showFactorHelp = id; 
-            }; 
-            CLASS = FirstResponder; 
-            LANGUAGE = ObjC; 
-            SUPERCLASS = NSObject; 
-        }
-    ); 
-    IBVersion = 1; 
-}

Factor.app/Contents/Resources/English.lproj/Factor.nib/designable.nib

@@ -0,0 +1,282 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<document type="com.apple.InterfaceBuilder3.Cocoa.XIB" version="3.0" toolsVersion="10116" systemVersion="15E65" targetRuntime="MacOSX.Cocoa" propertyAccessControl="none">
+    <dependencies>
+        <deployment version="1050" identifier="macosx"/>
+        <plugIn identifier="com.apple.InterfaceBuilder.CocoaPlugin" version="10116"/>
+    </dependencies>
+    <objects>
+        <customObject id="-2" userLabel="File's Owner" customClass="NSApplication"/>
+        <customObject id="-1" userLabel="First Responder" customClass="FirstResponder"/>
+        <customObject id="-3" userLabel="Application" customClass="NSObject"/>
+        <menu title="Factor.app:Contents:Resources:English.lproj:MenuBar" systemMenu="main" id="29" userLabel="MainMenu">
+            <items>
+                <menuItem title="Factor" id="56">
+                    <menu key="submenu" title="Factor" systemMenu="apple" id="57">
+                        <items>
+                            <menuItem title="About Factor" id="58">
+                                <modifierMask key="keyEquivalentModifierMask"/>
+                                <connections>
+                                    <action selector="orderFrontStandardAboutPanel:" target="-2" id="142"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="236">
+                                <modifierMask key="keyEquivalentModifierMask" command="YES"/>
+                            </menuItem>
+                            <menuItem title="Run Factor Source…" keyEquivalent="o" id="366">
+                                <modifierMask key="keyEquivalentModifierMask" option="YES" command="YES"/>
+                                <connections>
+                                    <action selector="runFactorFile:" target="-1" id="rgF-Ks-Gn8"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Save Factor Image" keyEquivalent="s" id="368">
+                                <modifierMask key="keyEquivalentModifierMask" option="YES" command="YES"/>
+                                <connections>
+                                    <action selector="saveFactorImage:" target="-1" id="Iu7-Jk-Gn3"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Save Factor Image As…" keyEquivalent="S" id="369">
+                                <modifierMask key="keyEquivalentModifierMask" option="YES" command="YES"/>
+                                <connections>
+                                    <action selector="saveFactorImageAs:" target="-1" id="YdH-jx-wV1"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="365"/>
+                            <menuItem title="Services" id="131">
+                                <menu key="submenu" title="Services" systemMenu="services" id="130"/>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="144">
+                                <modifierMask key="keyEquivalentModifierMask" command="YES"/>
+                            </menuItem>
+                            <menuItem title="Hide Factor" keyEquivalent="h" id="134">
+                                <connections>
+                                    <action selector="hide:" target="-2" id="152"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Hide Others" keyEquivalent="h" id="145">
+                                <modifierMask key="keyEquivalentModifierMask" option="YES" command="YES"/>
+                                <connections>
+                                    <action selector="hideOtherApplications:" target="-2" id="146"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Show All" id="150">
+                                <connections>
+                                    <action selector="unhideAllApplications:" target="-2" id="153"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="149">
+                                <modifierMask key="keyEquivalentModifierMask" command="YES"/>
+                            </menuItem>
+                            <menuItem title="Quit Factor" keyEquivalent="q" id="136">
+                                <connections>
+                                    <action selector="terminate:" target="-2" id="139"/>
+                                </connections>
+                            </menuItem>
+                        </items>
+                    </menu>
+                </menuItem>
+                <menuItem title="File" id="343">
+                    <modifierMask key="keyEquivalentModifierMask"/>
+                    <menu key="submenu" title="File" id="344">
+                        <items>
+                            <menuItem title="New" keyEquivalent="n" id="345">
+                                <connections>
+                                    <action selector="newDocument:" target="-1" id="358"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Open…" keyEquivalent="o" id="346">
+                                <connections>
+                                    <action selector="openDocument:" target="-1" id="359"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="348"/>
+                            <menuItem title="Close" keyEquivalent="w" id="349">
+                                <connections>
+                                    <action selector="performClose:" target="-1" id="360"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Save" keyEquivalent="s" id="350">
+                                <connections>
+                                    <action selector="saveDocument:" target="-1" id="361"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Save As…" keyEquivalent="S" id="351">
+                                <connections>
+                                    <action selector="saveDocumentAs:" target="-1" id="362"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Revert" id="352">
+                                <modifierMask key="keyEquivalentModifierMask"/>
+                                <connections>
+                                    <action selector="revertDocumentToSaved:" target="-1" id="363"/>
+                                </connections>
+                            </menuItem>
+                        </items>
+                    </menu>
+                </menuItem>
+                <menuItem title="Edit" id="304">
+                    <menu key="submenu" title="Edit" id="305">
+                        <items>
+                            <menuItem title="Undo" keyEquivalent="z" id="306">
+                                <connections>
+                                    <action selector="undo:" target="-1" id="332"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Redo" keyEquivalent="Z" id="307">
+                                <connections>
+                                    <action selector="redo:" target="-1" id="333"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="308">
+                                <modifierMask key="keyEquivalentModifierMask" command="YES"/>
+                            </menuItem>
+                            <menuItem title="Cut" keyEquivalent="x" id="309">
+                                <connections>
+                                    <action selector="cut:" target="-1" id="341"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Copy" keyEquivalent="c" id="310">
+                                <connections>
+                                    <action selector="copy:" target="-1" id="335"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Paste" keyEquivalent="v" id="311">
+                                <connections>
+                                    <action selector="paste:" target="-1" id="336"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Delete" id="313">
+                                <connections>
+                                    <action selector="delete:" target="-1" id="337"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Select All" keyEquivalent="a" id="314">
+                                <connections>
+                                    <action selector="selectAll:" target="-1" id="338"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="315">
+                                <modifierMask key="keyEquivalentModifierMask" command="YES"/>
+                            </menuItem>
+                            <menuItem title="Find" id="316">
+                                <menu key="submenu" title="Find" id="326">
+                                    <items>
+                                        <menuItem title="Find…" tag="1" keyEquivalent="f" id="327"/>
+                                        <menuItem title="Find Next" tag="2" keyEquivalent="g" id="328"/>
+                                        <menuItem title="Find Previous" tag="3" keyEquivalent="G" id="329"/>
+                                        <menuItem title="Use Selection for Find" tag="7" keyEquivalent="e" id="330"/>
+                                        <menuItem title="Jump to Selection" keyEquivalent="j" id="331"/>
+                                    </items>
+                                </menu>
+                            </menuItem>
+                            <menuItem title="Spelling" id="317">
+                                <menu key="submenu" title="Spelling" id="322">
+                                    <items>
+                                        <menuItem title="Spelling…" keyEquivalent=":" id="323"/>
+                                        <menuItem title="Check Spelling" keyEquivalent=";" id="324"/>
+                                        <menuItem title="Check Spelling as You Type" id="325"/>
+                                    </items>
+                                </menu>
+                            </menuItem>
+                            <menuItem title="Speech" id="318">
+                                <menu key="submenu" title="Speech" id="319">
+                                    <items>
+                                        <menuItem title="Start Speaking" id="320"/>
+                                        <menuItem title="Stop Speaking" id="321"/>
+                                    </items>
+                                </menu>
+                            </menuItem>
+                        </items>
+                    </menu>
+                </menuItem>
+                <menuItem title="Tools" id="283">
+                    <menu key="submenu" title="Tools" id="284">
+                        <items>
+                            <menuItem title="Show Listener" keyEquivalent="l" id="286">
+                                <connections>
+                                    <action selector="showFactorListener:" target="-1" id="r8I-gi-bmO"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="New Listener" keyEquivalent="L" id="287">
+                                <modifierMask key="keyEquivalentModifierMask" shift="YES" command="YES"/>
+                                <connections>
+                                    <action selector="newFactorListener:" target="-1" id="7yk-oP-H5Z"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="290">
+                                <modifierMask key="keyEquivalentModifierMask" command="YES"/>
+                            </menuItem>
+                            <menuItem title="Show Browser" keyEquivalent="b" id="288">
+                                <connections>
+                                    <action selector="showFactorBrowser:" target="-1" id="g0e-dO-s7I"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="New Browser" keyEquivalent="B" id="289">
+                                <modifierMask key="keyEquivalentModifierMask" shift="YES" command="YES"/>
+                                <connections>
+                                    <action selector="newFactorBrowser:" target="-1" id="cLP-Ug-xfc"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="PMQ-EN-0tV">
+                                <modifierMask key="keyEquivalentModifierMask" command="YES"/>
+                            </menuItem>
+                            <menuItem title="Switch Theme" id="Wvq-ot-R3p">
+                                <modifierMask key="keyEquivalentModifierMask"/>
+                                <menu key="submenu" title="Switch Theme" id="HqQ-K2-6Sn">
+                                    <items>
+                                        <menuItem title="Light" id="dSP-rb-Ak9">
+                                            <modifierMask key="keyEquivalentModifierMask"/>
+                                            <connections>
+                                                <action selector="switchLightTheme:" target="-1" id="Y29-I0-nL0"/>
+                                            </connections>
+                                        </menuItem>
+                                        <menuItem title="Dark" id="hBk-Ue-CIf">
+                                            <modifierMask key="keyEquivalentModifierMask"/>
+                                            <connections>
+                                                <action selector="switchDarkTheme:" target="-1" id="2ug-u3-tEU"/>
+                                            </connections>
+                                        </menuItem>
+                                    </items>
+                                </menu>
+                            </menuItem>
+                        </items>
+                    </menu>
+                </menuItem>
+                <menuItem title="Window" id="19">
+                    <menu key="submenu" title="Window" systemMenu="window" id="24">
+                        <items>
+                            <menuItem title="Minimize" keyEquivalent="m" id="23">
+                                <connections>
+                                    <action selector="performMiniaturize:" target="-1" id="37"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem title="Zoom" id="239">
+                                <connections>
+                                    <action selector="performZoom:" target="-1" id="240"/>
+                                </connections>
+                            </menuItem>
+                            <menuItem isSeparatorItem="YES" id="92">
+                                <modifierMask key="keyEquivalentModifierMask" command="YES"/>
+                            </menuItem>
+                            <menuItem title="Bring All to Front" id="5">
+                                <connections>
+                                    <action selector="arrangeInFront:" target="-1" id="39"/>
+                                </connections>
+                            </menuItem>
+                        </items>
+                    </menu>
+                </menuItem>
+                <menuItem title="Help" id="103">
+                    <menu key="submenu" title="Help" id="106">
+                        <items>
+                            <menuItem title="Factor Help" keyEquivalent="?" id="111">
+                                <connections>
+                                    <action selector="showFactorBrowser:" target="-1" id="Ddd-ic-q9J"/>
+                                </connections>
+                            </menuItem>
+                        </items>
+                    </menu>
+                </menuItem>
+            </items>
+        </menu>
+    </objects>
+</document>

Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib

@@ -1,21 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
-<plist version="1.0">
-<dict>
-	<key>IBDocumentLocation</key>
-	<string>557 119 525 491 0 0 2560 1578 </string>
-	<key>IBEditorPositions</key>
-	<dict>
-		<key>29</key>
-		<string>326 905 420 44 0 0 2560 1578 </string>
-	</dict>
-	<key>IBFramework Version</key>
-	<string>439.0</string>
-	<key>IBOpenObjects</key>
-	<array>
-		<integer>29</integer>
-	</array>
-	<key>IBSystem Version</key>
-	<string>8L127</string>
-</dict>
-</plist>

Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib

@@ -0,0 +1,32 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+	<key>IBClasses</key>
+	<array>
+		<dict>
+			<key>ACTIONS</key>
+			<dict>
+				<key>newFactorWorkspace</key>
+				<string>id</string>
+				<key>runFactorFile</key>
+				<string>id</string>
+				<key>saveFactorImage</key>
+				<string>id</string>
+				<key>saveFactorImageAs</key>
+				<string>id</string>
+				<key>showFactorHelp</key>
+				<string>id</string>
+			</dict>
+			<key>CLASS</key>
+			<string>FirstResponder</string>
+			<key>LANGUAGE</key>
+			<string>ObjC</string>
+			<key>SUPERCLASS</key>
+			<string>NSObject</string>
+		</dict>
+	</array>
+	<key>IBVersion</key>
+	<string>1</string>
+</dict>
+</plist>

Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib

@@ -0,0 +1,18 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+	<key>IBFramework Version</key>
+	<string>677</string>
+	<key>IBOldestOS</key>
+	<integer>5</integer>
+	<key>IBOpenObjects</key>
+	<array>
+		<integer>293</integer>
+	</array>
+	<key>IBSystem Version</key>
+	<string>9J61</string>
+	<key>targetFramework</key>
+	<string>IBCocoaFramework</string>
+</dict>
+</plist>

GNUmakefile

@@ -0,0 +1,272 @@
+ifdef CONFIG
+	VERSION = 0.99
+	GIT_LABEL = $(shell echo `git describe --all`-`git rev-parse HEAD`)
+	BUNDLE = Factor.app
+	DEBUG ?= 0
+	REPRODUCIBLE ?= 0
+
+	# gmake's default CXX is g++, we prefer c++
+	SHELL_CXX = $(shell printenv CXX)
+	ifeq ($(SHELL_CXX),)
+		CXX=c++
+	else
+		CXX=$(SHELL_CXX)
+	endif
+
+	XCODE_PATH ?= /Applications/Xcode.app
+	MACOSX_32_SDK ?= MacOSX10.11.sdk
+	MACOSX_SDK ?= MacOSX10.13.sdk
+
+	include $(CONFIG)
+
+	CFLAGS += -Wall \
+		-pedantic \
+		-DFACTOR_VERSION="$(VERSION)" \
+		-DFACTOR_GIT_LABEL="$(GIT_LABEL)" \
+		$(SITE_CFLAGS)
+
+	CXXFLAGS += -std=c++11
+
+	ifneq ($(DEBUG), 0)
+		CFLAGS += -g -DFACTOR_DEBUG
+	else
+		CFLAGS += -O3
+	endif
+
+	ifneq ($(REPRODUCIBLE), 0)
+		CFLAGS += -DFACTOR_REPRODUCIBLE
+	endif
+
+	ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
+	EXECUTABLE = factor$(EXE_SUFFIX)$(EXE_EXTENSION)
+	CONSOLE_EXECUTABLE = factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION)
+
+	DLL_OBJS = $(PLAF_DLL_OBJS) \
+		vm/aging_collector.o \
+		vm/alien.o \
+		vm/arrays.o \
+		vm/bignum.o \
+		vm/byte_arrays.o \
+		vm/callbacks.o \
+		vm/callstack.o \
+		vm/code_blocks.o \
+		vm/code_heap.o \
+		vm/compaction.o \
+		vm/contexts.o \
+		vm/data_heap.o \
+		vm/data_heap_checker.o \
+		vm/debug.o \
+		vm/dispatch.o \
+		vm/entry_points.o \
+		vm/errors.o \
+		vm/factor.o \
+		vm/full_collector.o \
+		vm/gc.o \
+		vm/image.o \
+		vm/inline_cache.o \
+		vm/instruction_operands.o \
+		vm/io.o \
+		vm/jit.o \
+		vm/math.o \
+		vm/mvm.o \
+		vm/nursery_collector.o \
+		vm/object_start_map.o \
+		vm/objects.o \
+		vm/primitives.o \
+		vm/quotations.o \
+		vm/run.o \
+		vm/safepoints.o \
+		vm/sampling_profiler.o \
+		vm/strings.o \
+		vm/to_tenured_collector.o \
+		vm/tuples.o \
+		vm/utilities.o \
+		vm/vm.o \
+		vm/words.o
+
+	MASTER_HEADERS = $(PLAF_MASTER_HEADERS) \
+		vm/assert.hpp \
+		vm/debug.hpp \
+		vm/layouts.hpp \
+		vm/platform.hpp \
+		vm/primitives.hpp \
+		vm/segments.hpp \
+		vm/gc_info.hpp \
+		vm/contexts.hpp \
+		vm/run.hpp \
+		vm/objects.hpp \
+		vm/sampling_profiler.hpp \
+		vm/errors.hpp \
+		vm/bignumint.hpp \
+		vm/bignum.hpp \
+		vm/booleans.hpp \
+		vm/instruction_operands.hpp \
+		vm/code_blocks.hpp \
+		vm/bump_allocator.hpp \
+		vm/bitwise_hacks.hpp \
+		vm/mark_bits.hpp \
+		vm/free_list.hpp \
+		vm/fixup.hpp \
+		vm/write_barrier.hpp \
+		vm/object_start_map.hpp \
+		vm/aging_space.hpp \
+		vm/tenured_space.hpp \
+		vm/data_heap.hpp \
+		vm/code_heap.hpp \
+		vm/gc.hpp \
+		vm/float_bits.hpp \
+		vm/io.hpp \
+		vm/image.hpp \
+		vm/callbacks.hpp \
+		vm/dispatch.hpp \
+		vm/vm.hpp \
+		vm/allot.hpp \
+		vm/tagged.hpp \
+		vm/data_roots.hpp \
+		vm/code_roots.hpp \
+		vm/generic_arrays.hpp \
+		vm/callstack.hpp \
+		vm/slot_visitor.hpp \
+		vm/to_tenured_collector.hpp \
+		vm/arrays.hpp \
+		vm/math.hpp \
+		vm/byte_arrays.hpp \
+		vm/jit.hpp \
+		vm/quotations.hpp \
+		vm/inline_cache.hpp \
+		vm/mvm.hpp \
+		vm/factor.hpp \
+		vm/utilities.hpp
+
+	EXE_OBJS = $(PLAF_EXE_OBJS)
+
+	FFI_TEST_LIBRARY = libfactor-ffi-test$(SHARED_DLL_EXTENSION)
+
+	TEST_OBJS = vm/ffi_test.o
+endif
+
+default:
+	$(MAKE) `./build.sh make-target`
+
+help:
+	@echo "Run '$(MAKE)' with one of the following parameters:"
+	@echo ""
+	@echo "linux-x86-32"
+	@echo "linux-x86-64"
+	@echo "linux-ppc-32"
+	@echo "linux-ppc-64"
+	@echo "linux-arm"
+	@echo "freebsd-x86-32"
+	@echo "freebsd-x86-64"
+	@echo "macosx-x86-32"
+	@echo "macosx-x86-64"
+	@echo "macosx-x86-fat"
+	@echo "windows-x86-32"
+	@echo "windows-x86-64"
+	@echo ""
+	@echo "Additional modifiers:"
+	@echo ""
+	@echo "DEBUG=1  compile VM with debugging information"
+	@echo "REPRODUCIBLE=1  compile VM without timestamp"
+	@echo "SITE_CFLAGS=...  additional optimization flags"
+	@echo "X11=1  force link with X11 libraries instead of Cocoa (only on Mac OS X)"
+
+ALL = factor factor-ffi-test factor-lib
+
+freebsd-x86-32:
+	$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32
+
+freebsd-x86-64:
+	$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.64
+
+macosx-x86-32:
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.32
+
+macosx-x86-64:
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.64
+
+macosx-x86-fat:
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.fat
+
+linux-x86-32:
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.32
+
+linux-x86-64:
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64
+
+linux-ppc-32:
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.32
+
+linux-ppc-64:
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.64
+
+linux-arm:
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.arm
+
+windows-x86-32:
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.32
+	$(MAKE) factor-console CONFIG=vm/Config.windows.x86.32
+
+windows-x86-64:
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.64
+	$(MAKE) factor-console CONFIG=vm/Config.windows.x86.64
+
+ifdef CONFIG
+
+macosx.app: factor
+	mkdir -p $(BUNDLE)/Contents/MacOS
+	mkdir -p $(BUNDLE)/Contents/Frameworks
+	mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
+	ln -s Factor.app/Contents/MacOS/factor ./factor
+
+$(ENGINE): $(DLL_OBJS)
+	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
+
+factor-lib: $(ENGINE)
+
+factor: $(EXE_OBJS) $(DLL_OBJS)
+	$(TOOLCHAIN_PREFIX)$(CXX) -L. $(DLL_OBJS) \
+		$(CFLAGS) $(CXXFLAGS) -o $(EXECUTABLE) $(LIBS) $(EXE_OBJS)
+
+factor-console: $(EXE_OBJS) $(DLL_OBJS)
+	$(TOOLCHAIN_PREFIX)$(CXX) -L. $(DLL_OBJS) \
+		$(CFLAGS) $(CXXFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(LIBS) $(EXE_OBJS)
+
+factor-ffi-test: $(FFI_TEST_LIBRARY)
+
+$(FFI_TEST_LIBRARY): vm/ffi_test.o
+	$(TOOLCHAIN_PREFIX)$(CC) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o $(FFI_TEST_LIBRARY) $(TEST_OBJS)
+
+vm/resources.o:
+	$(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
+
+vm/ffi_test.o: vm/ffi_test.c
+	$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -std=c99 -o $@ $<
+
+vm/master.hpp.gch: vm/master.hpp $(MASTER_HEADERS)
+	$(TOOLCHAIN_PREFIX)$(CXX) -c -x c++-header $(CFLAGS) $(CXXFLAGS) -o $@ $<
+
+%.o: %.cpp vm/master.hpp.gch
+	$(TOOLCHAIN_PREFIX)$(CXX) -c $(CFLAGS) $(CXXFLAGS) -o $@ $<
+
+%.o: %.S
+	$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(CXXFLAGS) -o $@ $<
+
+%.o: %.mm vm/master.hpp.gch
+	$(TOOLCHAIN_PREFIX)$(CXX) -c $(CFLAGS) $(CXXFLAGS) -o $@ $<
+
+.SUFFIXES: .mm
+
+endif
+
+clean:
+	rm -f vm/*.gch
+	rm -f vm/*.o
+	rm -f factor.dll
+	rm -f factor.lib
+	rm -f factor.dll.lib
+	rm -f libfactor.*
+	rm -f libfactor-ffi-test.*
+	rm -f Factor.app/Contents/Frameworks/libfactor.dylib
+
+.PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app

LICENSE.txt

@@ -0,0 +1,22 @@
+Copyright (c) 2020, Slava Pestov, et al.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Makefile

@@ -1,152 +0,0 @@
-CC = gcc
-
-BINARY = f
-IMAGE = factor.image
-BUNDLE = Factor.app
-VERSION = 0.87
-DISK_IMAGE_DIR = Factor-$(VERSION)
-DISK_IMAGE = Factor-$(VERSION).dmg
-LIBPATH = -L/usr/X11R6/lib
-
-ifdef DEBUG
-	CFLAGS = -g -std=gnu99
-	STRIP = touch
-else
-	CFLAGS = -Wall -O3 -ffast-math -std=gnu99 $(SITE_CFLAGS)
-	STRIP = strip
-endif
-
-ifdef CONFIG
-	include $(CONFIG)
-endif
-
-OBJS = $(PLAF_OBJS) \
-	vm/alien.o \
-	vm/bignum.o \
-	vm/compiler.o \
-	vm/debug.o \
-	vm/factor.o \
-	vm/ffi_test.o \
-	vm/image.o \
-	vm/io.o \
-	vm/math.o \
-	vm/data_gc.o \
-	vm/code_gc.o \
-	vm/primitives.o \
-	vm/run.o \
-	vm/stack.o \
-	vm/types.o
-
-default:
-	@echo "Run 'make' with one of the following parameters:"
-	@echo ""
-	@echo "freebsd"
-	@echo "linux-x86"
-	@echo "linux-amd64"
-	@echo "linux-ppc"
-	@echo "macosx-x86"
-	@echo "macosx-ppc"
-	@echo "solaris"
-	@echo "windows"
-	@echo ""
-	@echo "On Unix, pass NO_UI=1 if you don't want to link with the"
-	@echo "X11 and OpenGL libraries."
-	@echo ""
-	@echo "On Mac OS X, pass X11=1 if you want to link with the"
-	@echo "X11 library instead of Cocoa. You will also need to bootstrap"
-	@echo "Factor with the -no-cocoa -x11 switches."
-	@echo
-	@echo "Also, you might want to set the SITE_CFLAGS environment"
-	@echo "variable to enable some CPU-specific optimizations; this"
-	@echo "can make a huge difference. Eg:"
-	@echo ""
-	@echo "export SITE_CFLAGS=\"-march=pentium4 -ffast-math\""
-
-freebsd:
-	$(MAKE) $(BINARY) CONFIG=vm/Config.freebsd
-
-macosx-freetype:
-	ln -sf libfreetype.6.dylib \
-		Factor.app/Contents/Frameworks/libfreetype.dylib
-
-macosx-ppc: macosx-freetype
-	$(MAKE) $(BINARY) CONFIG=vm/Config.macosx.ppc
-
-macosx-x86: macosx-freetype
-	$(MAKE) $(BINARY) CONFIG=vm/Config.macosx.x86
-
-linux-x86:
-	$(MAKE) $(BINARY) CONFIG=vm/Config.linux.x86
-	$(STRIP) $(BINARY)
-
-linux-amd64:
-	$(MAKE) $(BINARY) CONFIG=vm/Config.linux.amd64
-	$(STRIP) $(BINARY)
-
-linux-ppc:
-	$(MAKE) $(BINARY) CONFIG=vm/Config.linux.ppc
-	$(STRIP) $(BINARY)
-
-solaris solaris-x86 solaris-amd64:
-	$(MAKE) $(BINARY) CONFIG=vm/Config.solaris
-	$(STRIP) $(BINARY)
-
-windows:
-	$(MAKE) $(BINARY) CONFIG=vm/Config.windows
-
-macosx.app:
-	cp $(BINARY) $(BUNDLE)/Contents/MacOS/Factor
-
-	install_name_tool \
-		-id @executable_path/../Frameworks/libfreetype.6.dylib \
-		Factor.app/Contents/Frameworks/libfreetype.6.dylib
-	install_name_tool \
-		-change /usr/X11R6/lib/libfreetype.6.dylib \
-		@executable_path/../Frameworks/libfreetype.6.dylib \
-		Factor.app/Contents/MacOS/Factor
-
-macosx.dmg:
-	rm -f $(DISK_IMAGE)
-	rm -rf $(DISK_IMAGE_DIR)
-	mkdir $(DISK_IMAGE_DIR)
-	mkdir -p $(DISK_IMAGE_DIR)/Factor/
-	cp -R $(BUNDLE) $(DISK_IMAGE_DIR)/Factor/$(BUNDLE)
-	chmod +x cp_dir
-	cp factor.image license.txt README.txt TODO.FACTOR.txt \
-		$(DISK_IMAGE_DIR)/Factor/
-	find doc library contrib examples fonts \( -name '*.factor' \
-		-o -name '*.facts' \
-		-o -name '*.txt' \
-		-o -name '*.html' \
-		-o -name '*.ttf' \
-		-o -name '*.el' \
-		-o -name '*.vim' \
-		-o -name '*.fgen' \
-		-o -name '*.tex' \
-		-o -name '*.fhtml' \
-		-o -name '*.xml' \
-		-o -name '*.js' \) \
-		-exec ./cp_dir {} $(DISK_IMAGE_DIR)/Factor/{} \;
-	hdiutil create -srcfolder "$(DISK_IMAGE_DIR)" -fs HFS+ \
-		-volname "$(DISK_IMAGE_DIR)" "$(DISK_IMAGE)"
-
-tags:
-	ctags-exuberant vm/*.[chm]
-
-f: $(OBJS)
-	$(CC) $(LIBS) $(LIBPATH) $(CFLAGS) -o $@$(PLAF_SUFFIX) $(OBJS)
-
-clean:
-	rm -f vm/*.o
-
-clean.app:
-	rm -f $(BUNDLE)/Contents/MacOS/Factor
-
-.c.o:
-	$(CC) -c $(CFLAGS) -o $@ $<
-
-.S.o:
-	$(CC) -c $(CFLAGS) -o $@ $<
-
-.m.o:
-	$(CC) -c $(CFLAGS) -o $@ $<

Nmakefile

@@ -0,0 +1,205 @@
+VERSION = 0.99
+
+# Crazy hack to do shell commands
+# We do it in Nmakefile because that way we don't have to invoke build through build.cmd
+# and we can just do ``nmake /f Nmakefile x86-64-vista`` or similar
+# and we still get the git branch, id, etc
+
+!IF [git describe --all > git-describe.tmp] == 0
+GIT_DESCRIBE = \
+!INCLUDE <git-describe.tmp>
+!IF [del git-describe.tmp] == 0
+!ENDIF
+!ENDIF
+
+!IF [git rev-parse HEAD > git-id.tmp] == 0
+GIT_ID = \
+!INCLUDE <git-id.tmp>
+!IF [del git-id.tmp] == 0
+!ENDIF
+!ENDIF
+
+!IF [git rev-parse --abbrev-ref HEAD > git-branch.tmp] == 0
+GIT_BRANCH = \
+!INCLUDE <git-branch.tmp>
+!IF [del git-branch.tmp] == 0
+!ENDIF
+!ENDIF
+
+GIT_LABEL = $(GIT_DESCRIBE)-$(GIT_ID)
+
+!IF DEFINED(PLATFORM)
+
+LINK_FLAGS = /nologo shell32.lib user32.lib
+CL_FLAGS = /nologo /O2 /WX /W3 /D_CRT_SECURE_NO_WARNINGS /DFACTOR_VERSION=$(VERSION) /DFACTOR_GIT_LABEL=$(GIT_LABEL)
+CL_FLAGS_VISTA = /D_WIN32_WINNT=0x0600
+
+!IF "$(PLATFORM)" == "x86-32"
+LINK_FLAGS = $(LINK_FLAGS) /safeseh /largeaddressaware
+PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj
+SUBSYSTEM_COM_FLAGS = console,"5.01"
+SUBSYSTEM_EXE_FLAGS = windows,"5.01"
+
+!ELSEIF "$(PLATFORM)" == "x86-32-vista"
+LINK_FLAGS = $(LINK_FLAGS) /safeseh /largeaddressaware
+CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
+PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj
+SUBSYSTEM_COM_FLAGS = console
+SUBSYSTEM_EXE_FLAGS = windows
+
+!ELSEIF "$(PLATFORM)" == "x86-64"
+PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
+SUBSYSTEM_COM_FLAGS = console,"5.02"
+SUBSYSTEM_EXE_FLAGS = windows,"5.02"
+
+
+!ELSEIF "$(PLATFORM)" == "x86-64-vista"
+CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
+PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
+SUBSYSTEM_COM_FLAGS = console
+SUBSYSTEM_EXE_FLAGS = windows
+
+!ELSE
+CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
+PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
+SUBSYSTEM_COM_FLAGS = console
+SUBSYSTEM_EXE_FLAGS = windows
+
+!ENDIF
+
+!IF DEFINED(DEBUG)
+LINK_FLAGS = $(LINK_FLAGS) /DEBUG
+CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
+!ENDIF
+
+!IF DEFINED(REPRODUCIBLE)
+CL_FLAGS = $(CL_FLAGS) /DFACTOR_REPRODUCIBLE
+!ENDIF
+
+ML_FLAGS = /nologo /safeseh
+
+EXE_OBJS = vm\main-windows.obj vm\factor.res
+
+DLL_OBJS = $(PLAF_DLL_OBJS) \
+	vm\os-windows.obj \
+	vm\aging_collector.obj \
+	vm\alien.obj \
+	vm\arrays.obj \
+	vm\bignum.obj \
+	vm\byte_arrays.obj \
+	vm\callbacks.obj \
+	vm\callstack.obj \
+	vm\code_blocks.obj \
+	vm\code_heap.obj \
+	vm\compaction.obj \
+	vm\contexts.obj \
+	vm\data_heap.obj \
+	vm\data_heap_checker.obj \
+	vm\debug.obj \
+	vm\dispatch.obj \
+	vm\entry_points.obj \
+	vm\errors.obj \
+	vm\factor.obj \
+	vm\full_collector.obj \
+	vm\gc.obj \
+	vm\image.obj \
+	vm\inline_cache.obj \
+	vm\instruction_operands.obj \
+	vm\io.obj \
+	vm\jit.obj \
+	vm\math.obj \
+	vm\mvm.obj \
+	vm\mvm-windows.obj \
+	vm\nursery_collector.obj \
+	vm\object_start_map.obj \
+	vm\objects.obj \
+	vm\primitives.obj \
+	vm\quotations.obj \
+	vm\run.obj \
+	vm\safepoints.obj \
+	vm\sampling_profiler.obj \
+	vm\strings.obj \
+	vm\to_tenured_collector.obj \
+	vm\tuples.obj \
+	vm\utilities.obj \
+	vm\vm.obj \
+	vm\words.obj
+
+# batch mode has ::
+.cpp.obj::
+	cl /EHsc $(CL_FLAGS) /MP /Fovm/ /c $<
+
+.c.obj::
+	cl /EHsc $(CL_FLAGS) /MP /Fovm/ /c $<
+
+.asm.obj:
+	ml $(ML_FLAGS) /Fo$@ /c $<
+
+.rs.res:
+	rc $<
+
+libfactor-ffi-test.dll: vm/ffi_test.obj
+	link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll /def:vm\ffi_test.def vm/ffi_test.obj
+
+factor.dll.lib: $(DLL_OBJS)
+	link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
+
+factor.com: $(EXE_OBJS) $(DLL_OBJS)
+	link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:$(SUBSYSTEM_COM_FLAGS) $(EXE_OBJS) $(DLL_OBJS)
+
+factor.exe: $(EXE_OBJS) $(DLL_OBJS)
+	link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:$(SUBSYSTEM_EXE_FLAGS) $(EXE_OBJS) $(DLL_OBJS)
+
+# If we compile factor.exe, run mt.exe, and run factor.exe,
+# then Windows caches the manifest. Even on a recompile without applying
+# the mt.exe tool, if the factor.exe.manifest file is present, the manifest
+# is applied. To avoid this, we delete the .manifest file on clean
+# and copy it from a reference file on compilation and mt.exe.
+#
+factor.exe.manifest: factor.exe
+	copy factor.exe.manifest.in factor.exe.manifest
+	mt -manifest factor.exe.manifest -outputresource:"factor.exe;#1"
+
+all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
+
+!ENDIF
+
+default:
+	@echo Usage: nmake /f Nmakefile platform
+	@echo Where platform is one of:
+	@echo x86-32
+	@echo x86-64
+	@echo x86-32-vista
+	@echo x86-64-vista
+	@exit 1
+
+x86-32:
+	nmake /nologo PLATFORM=x86-32 /f Nmakefile all
+
+x86-64:
+	nmake /nologo PLATFORM=x86-64 /f Nmakefile all
+
+x86-32-vista:
+	nmake /nologo PLATFORM=x86-32-vista /f Nmakefile all
+
+x86-64-vista:
+	nmake /nologo PLATFORM=x86-64-vista /f Nmakefile all
+
+clean:
+	del vm\*.obj
+	if exist vm\factor.res del vm\factor.res
+	if exist factor.lib del factor.lib
+	if exist factor.com del factor.com
+	if exist factor.exe del factor.exe
+	if exist factor.exe.manifest del factor.exe.manifest
+	if exist factor.exp del factor.exp
+	if exist factor.dll del factor.dll
+	if exist factor.dll.lib del factor.dll.lib
+	if exist factor.dll.exp del factor.dll.exp
+	if exist libfactor-ffi-test.dll del libfactor-ffi-test.dll
+	if exist libfactor-ffi-test.exp del libfactor-ffi-test.exp
+	if exist libfactor-ffi-test.lib del libfactor-ffi-test.lib
+
+.PHONY: all default x86-32 x86-64 x86-32-vista x86-64-vista clean factor.exe.manifest
+
+.SUFFIXES: .rs

README.md

@@ -0,0 +1,160 @@
+# Factor
+
+Factor is a [concatenative](https://www.concatenative.org), stack-based
+programming language with [high-level
+features](https://concatenative.org/wiki/view/Factor/Features/The%20language)
+including dynamic types, extensible syntax, macros, and garbage collection.
+On a practical side, Factor has a [full-featured
+library](https://docs.factorcode.org/content/article-vocab-index.html),
+supports many different platforms, and has been extensively documented.
+
+The implementation is [fully
+compiled](https://concatenative.org/wiki/view/Factor/Optimizing%20compiler)
+for performance, while still supporting [interactive
+development](https://concatenative.org/wiki/view/Factor/Interactive%20development).
+Factor applications are portable between all common platforms.  Factor can
+[deploy stand-alone
+applications](https://concatenative.org/wiki/view/Factor/Deployment) on all
+platforms.  Full source code for the Factor project is available under a BSD
+license.
+
+## Getting Started
+
+### Building Factor from source
+
+If you have a build environment set up, then you can build Factor from git.
+These scripts will attempt to compile the Factor binary and bootstrap from
+a boot image stored on factorcode.org.
+
+To check out Factor:
+
+* `git clone git://github.com/factor/factor.git`
+* `cd factor`
+
+To build the latest complete Factor system from git, either use the
+build script:
+
+* Unix: `./build.sh update`
+* Windows: `build.cmd`
+
+or download the correct boot image for your system from
+http://downloads.factorcode.org/images/master/, put it in the `factor`
+directory and run:
+
+* Unix: `make` and then `./factor -i=boot.unix-x86.64.image`
+* Windows: `nmake /f Nmakefile x86-64` and then `factor.com -i=boot.windows-x86.64.image`
+
+Now you should have a complete Factor system ready to run.
+
+More information on [building factor](https://concatenative.org/wiki/view/Factor/Building%20Factor)
+and [system requirements](https://concatenative.org/wiki/view/Factor/Requirements).
+
+### To run a Factor binary:
+
+You can download a Factor binary from the grid on [https://factorcode.org](https://factorcode.org).
+The nightly builds are usually a better experience than the point releases.
+
+* Windows: Double-click `factor.exe`, or run `.\factor.com` in a command prompt
+* Mac OS X: Double-click `Factor.app` or run `open Factor.app` in a Terminal
+* Unix: Run `./factor` in a shell
+
+### Learning Factor
+
+A tutorial is available that can be accessed from the Factor environment:
+
+```factor
+"first-program" help
+```
+
+Some other simple things you can try in the listener:
+
+```factor
+"Hello, world" print
+
+{ 4 8 15 16 23 42 } [ 2 * ] map .
+
+1000 [1,b] sum .
+
+4 <iota> [
+    "Happy Birthday " write
+    2 = "dear NAME" "to You" ? print
+] each
+```
+
+For more tips, see [Learning Factor](https://concatenative.org/wiki/view/Factor/Learning).
+
+## Documentation
+
+The Factor environment includes extensive reference documentation and a
+short "cookbook" to help you get started. The best way to read the
+documentation is in the UI; press F1 in the UI listener to open the help
+browser tool. You can also [browse the documentation
+online](https://docs.factorcode.org).
+
+## Command Line Usage
+
+Factor supports a number of command line switches:
+
+```
+Usage: factor [Factor arguments] [script] [script arguments]
+
+Common arguments:
+    -help            print this message and exit
+    -i=<image>       load Factor image file <image> (default factor.image)
+    -run=<vocab>     run the MAIN: entry point of <vocab>
+        -run=listener    run terminal listener
+        -run=ui.tools    run Factor development UI
+    -e=<code>        evaluate <code>
+    -no-user-init    suppress loading of .factor-rc
+    -roots=<paths>   a list of path-delimited extra vocab roots
+
+Enter
+    "command-line" help
+from within Factor for more information.
+```
+
+You can also write scripts that can be run from the terminal, by putting
+``#!/path/to/factor`` at the top of your scripts and making them executable.
+
+## Source Organization
+
+The Factor source tree is organized as follows:
+
+* `vm/` - Factor VM source code (not present in binary packages)
+* `core/` - Factor core library
+* `basis/` - Factor basis library, compiler, tools
+* `extra/` - more libraries and applications
+* `misc/` - editor modes, icons, etc
+* `unmaintained/` - now at [factor-unmaintained](https://github.com/factor/factor-unmaintained)
+
+## Source History
+
+During Factor's lifetime, sourcecode has lived in many repositories. Unfortunately, the first import in Git did not keep history. History has been partially recreated from what could be salvaged. Due to the nature of Git, it's only possible to add history without disturbing upstream work, by using replace objects. These need to be manually fetched, or need to be explicitly added to your git remote configuration.
+
+Use:
+`git fetch origin 'refs/replace/*:refs/replace/*'`
+
+or add the following line to your configuration file
+
+```
+[remote "origin"]
+    url = ...
+    fetch = +refs/heads/*:refs/remotes/origin/*
+    ...
+    fetch = +refs/replace/*:refs/replace/*
+```
+
+Then subsequent fetches will automatically update any replace objects.
+
+## Community
+
+Factor developers meet in the `#concatenative` channel on
+[irc.freenode.net](http://freenode.net). Drop by if you want to discuss
+anything related to Factor or language design in general.
+
+* [Factor homepage](https://factorcode.org)
+* [Concatenative languages wiki](https://concatenative.org)
+* [Mailing list](factor-talk@lists.sourceforge.net)
+* Search for "factorcode" on [Gitter](https://gitter.im/)
+
+Have fun!

README.txt

@@ -1,203 +0,0 @@
-The Factor programming language
--------------------------------
-
-This file covers installation and basic usage of the Factor
-implementation. It is not an introduction to the language itself.
-
-* Contents
-
-- Platform support
-- Compiling Factor
-- Building Factor
-- Running Factor on Unix with X11
-- Running Factor on Mac OS X - Cocoa UI
-- Running Factor on Mac OS X - X11 UI
-- Running Factor on Windows
-- Source organization
-- Community
-- Credits
-
-* Platform support
-
-Factor is fully supported on the following platforms:
-
-  Linux/x86
-  Linux/AMD64
-  Mac OS X/x86
-  Mac OS X/PowerPC
-  MS Windows XP
-
-The following platforms should work, but are not tested on a
-regular basis:
-
-  FreeBSD/x86
-  FreeBSD/AMD64
-  Solaris/x86
-  Solaris/AMD64
-  Linux/PowerPC
-
-Please donate time or hardware if you wish to see Factor running on
-other platforms.
-
-* Compiling Factor
-
-The Factor runtime is written in C, and is built with GNU make and gcc.
-
-Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
-3.3 or earlier.
-
-Run 'make' (or 'gmake' on non-Linux platforms) with one of the following
-parameters to build the Factor runtime:
-
-  freebsd
-  linux-x86
-  linux-amd64
-  linux-ppc
-  macosx-x86
-  macosx-ppc
-  solaris
-
-The following options can be given to make:
-
-  SITE_CFLAGS="..."
-  DEBUG=1
-
-The former allows optimization flags to be specified, for example
-"-march=pentium4 -ffast-math -O3". Nowadays most of the hard work is
-done by Factor compiled code, so optimizing the runtime is not that
-important. Usually the defaults are fine.
-
-The DEBUG flag disables optimization and builds an executable with
-debug symbols. This is probably only of interest to people intending to
-hack on the runtime sources.
-
-Compilation may print a handful of warnings about singled/unsigned
-comparisons, and violated aliasing contracts. They may safely be
-ignored.
-
-Compilation will yield an executable named 'f'.
-
-* Building Factor
-
-The boot images are no longer included with the Factor distribution
-due to size concerns. Instead, download a boot image from:
-
-  http://factorcode.org/images/0.85/
-
-Once you have compiled the Factor runtime, you must bootstrap the Factor
-system using the image that corresponds to your CPU architecture.
-
-Once you download the right image, bootstrap the system with the
-following command line:
-
-./f boot.image.<foo>
-
-Bootstrap can take a while, depending on your system. When the process
-completes, a 'factor.image' file will be generated. Note that this image
-is both CPU and OS-specific, so in general cannot be shared between
-machines.
-
-* Running Factor on Unix with X11
-
-On Unix, Factor can either run a graphical user interface using X11, or
-a terminal listener.
-
-If your DISPLAY environment variable is set, the UI will start
-automatically:
-
-  ./f factor.image
-
-To run an interactive terminal listener:
-
-  ./f factor.image -shell=tty
-
-If you're inside a terminal session, you can start the UI with one of
-the following two commands:
-
-  ui
-  [ ui ] in-thread
-  
-The latter keeps the terminal listener running.
-
-* Running Factor on Mac OS X - Cocoa UI
-
-On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the
-terminal listener. If you are using Mac OS X 10.3, you can only run the
-X11 UI, as documented in the next section.
-
-The 'f' executable runs the terminal listener:
-
-  ./f factor.image
-
-The Cocoa UI requires that after bootstrapping you build the Factor.app
-application bundle:
-
-  make macosx.app
-
-This copies the runtime executable, factor.image (which must exist at
-this point), and the library source into a self-contained Factor.app.
-
-* Running Factor on Mac OS X - X11 UI
-
-The X11 UI is available on Mac OS X, however its use is not recommended
-since it does not integrate with the host OS. However, if you are
-running Mac OS X 10.3, it is your only choice.
-
-When compiling Factor, pass the X11=1 parameter:
-
-  make macosx-ppc X11=1
-
-Then bootstrap with the following pair of switches:
-
-  ./f boot.image.ppc -no-cocoa -x11
-
-Now if $DISPLAY is set, running ./f will start the UI.
-
-* Running Factor on Windows
-
-If you did not download the binary package, you can bootstrap Factor in
-the command prompt:
-
-  f.exe boot.image.pentium4 (or boot.image.x86)
-
-Once bootstrapped, double-clicking f.exe starts the Factor UI.
-
-To run the listener in the command prompt:
-
-  f.exe -shell=tty
-
-* Source organization
-
-The following four directories are managed by the module system; consult
-the documentation for details:
-
-  apps/ - user-contributed applications
-  libs/ - user-contributed libraries
-  demos/ - small examples illustrating various language features
-  core/ - sources for the library, written in Factor
-
-  fonts/ - TrueType fonts used by UI
-  vm/ - sources for the Factor runtime, written in C
-
-* Community
-
-The Factor homepage is located at http://factorcode.org/.
-
-Factor developers meet in the #concatenative channel on the
-irc.freenode.net server. Drop by if you want to discuss anything related
-to Factor or language design in general.
-
-* Credits
-
-The following people have contributed code to the Factor core:
-
-Slava Pestov:       Lead developer
-Alex Chapman:       OpenGL binding
-Doug Coleman:       Mersenne Twister RNG, Windows port
-Eduardo Cavazos:    X11 binding
-Joshua Grams:       PowerPC instruction cache flush code
-Mackenzie Straight: Windows port
-
-Have fun!
-
-:tabSize=2:indentSize=2:noTabs=true:

TODO.txt

@@ -1,108 +0,0 @@
-+ 0.87:
-
-- callback scheduling issue
-- error popup obscures input area
-- ui docs
-- test factor on linux/ppc
-
-+ 0.88:
-
-- poorly documented vocabs:
-  - alien
-  - cocoa
-  - command-line
-  - compiler
-  - completion
-  - image
-  - interpreter
-  - objc
-  - optimizer
-- calling 'see' with an nonexistent method should be an error
-- grid-lines are rendered incorrectly
-- interactor: show stack effect for word at caret in status bar
-- lisppaste gui
-- growable data heap
-- variable width word wrap
-- graphical crossref tool
-- inspector where slot values can be changed
-- compiled call traces do not work if the runtime is built with
-  -fomit-frame-pointer on ppc
-- use crc32 instead of modification date in reload-modules
-- models: don't do redundant work
-- top level window positioning on ms windows
-- httpd crash
-- these things are "Too Slow":
-  - make-image
-  - workspace-window
-  - apropos
-  - 10000 [ dup number>string ] map describe in the UI
-  - available-modules
-  - :trace
-  - string-lines
-  - md5, crc32
-  - all-words [ word-name ] map prune [ words-named ] map
-  - 100000 [ "\"hello\" not" eval drop ] times
-- auto-update browser and help when sources reload
-- mac intel: struct returns from objc methods
-- new windows don't always have focus, eg focus follows mouse
-- recompile get/set/>n/n>/ndrop if needed
-- cross-word type inference
-- some kind of declarative wiring framework for ui
-- if we're printing a block on multiple lines, break at some words like
-  set off on % # , ... and assembler opcodes
-- don't end lines with literals, shuffle words or symbols?
-- see should try to not show ; on a line by itself
-- IN: on its own line if the entire 'see' form doesn't fit
-- command buttons: indicate shortcuts
-- test what is done in the case of an invalid declaration on an inline
-  recursive
-- how do we refer to command shortcuts in the docs?
-
-+ ui:
-
-- browser tool: dropdown menu button for definition operations
-- copying pane output
-- editor:
-  - autoscroll
-  - transpose char/word/line
-  - more efficient multi-line inserts
-- see if its possible to only repaint dirty regions
-- structure editor
-
-+ compiler/ffi:
-
-- C types should be words
-  - TYPEDEF: float { ... } { ... } ;   ==> \ float T{ c-type ... } "c-type" swp
-  - TYPEDEF: float FTFloat ;  ==> \ float \ FTFloat "c-type" swp
-  - make typedef aliasing explicit
-- seeing a C struct word should show its def
-- amd64 structs-by-value bug
-- %allot-bignum-signed-2 is broken on both platforms
-- [ [ dup call ] dup call ] infer hangs
-- stdcall callbacks
-- callstack overflow when compiling mutually recursive inline words
-- arm backend
-- float= doesn't consider nans equal
-- C functions returning structs by value
-- compiled continuations
-
-+ misc:
-
-- if a word drops the stack pointer below the bottom, then an error
-  won't be thrown until the next word accesses the stack
-- prettyprinter: don't build entire tree to print first
-- automatic help/effects for slot accessors
-- tuple shape changes
-- should be possible to reload any source file in library
-- minor GC takes too long now, we should card mark code heap
-- buffer-ptr should be an alien
-- swap nappend ==> nappend
-- incremental GC
-- UDP
-- slice: if sequence or seq start is changed, abstraction violation
-- hashed generic method dispatch
-
-+ httpd:
-
-- remaining HTML issues need fixing
-- embedded.factor is O(n^2)

apps/all.factor

@@ -1,13 +0,0 @@
-USING: words kernel modules ;
-
-REQUIRES: apps/automata apps/benchmarks apps/boids
-apps/factorbot apps/fjsc-responder apps/furnace-pastebin 
-apps/hexdump apps/lindenmayer apps/mandel apps/random-tester
-apps/raytracer apps/rss apps/space-invaders apps/tetris
-apps/turing ;
-
-"x11" vocab [
-    "apps/factory" require
-] when
-
-PROVIDE: apps/all ;

apps/automata.factor

@@ -1,170 +0,0 @@
-REQUIRES: libs/vars libs/slate apps/lindenmayer/opengl ;
-
-USING: kernel namespaces hashtables sequences generic math arrays
-       threads opengl gadgets
-       vars slate opengl-contrib ;
-
-IN: automata
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! set-rule
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: char>digit ( c -- i ) 48 - ;
-
-: string>digits ( s -- seq ) >array [ char>digit ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: rule   VAR: rule-number
-
-: init-rule ( -- ) 8 <hashtable> >rule ;
-
-: rule-keys ( -- array )
-{ { 1 1 1 }
-  { 1 1 0 }
-  { 1 0 1 }
-  { 1 0 0 }
-  { 0 1 1 }
-  { 0 1 0 }
-  { 0 0 1 }
-  { 0 0 0 } } ;
-
-: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
-
-: set-rule ( n -- )
-dup >rule-number rule-values rule-keys [ rule> set-hash ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! step-capped-line
-! step-wrapped-line
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 3nth ( n seq -- slice ) >r dup 3 + r> <slice> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: map3-i ( seq -- i ) length 2 - ;
-
-: map3-quot ( quot -- quot ) [ swap 3nth ] swap append ;
-
-: map3 ( seq quot -- seq ) over map3-i swap map3-quot map-with ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pattern>state ( {_a_b_c_} -- state ) rule> hash ;
-
-: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
-
-: wrap-line ( a-line-z -- za-line-za )
-dup peek 1array swap dup first 1array append append ;
-
-: step-line ( line -- new-line ) [ >array pattern>state ] map3 ;
-
-: step-capped-line ( line -- new-line ) cap-line step-line ;
-
-: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: window-width ( -- width ) slate> rect-dim 0 swap nth ;
-
-: window-height ( -- height ) slate> rect-dim 1 swap nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-line ( -- line ) window-width [ drop 2 random-int ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: center-i ( -- i ) window-width 2 / >fixnum ;
-
-: center-line ( -- line ) center-i window-width [ = [ 1 ] [ 0 ] if ] map-with ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-item ( seq -- item ) dup length random-int swap nth ;
-
-: interesting ( -- seq )
-{ 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
-  110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
-
-: mild ( -- seq )
-{ 6 9 11 57 62 74 118 } ;
-
-: set-interesting ( -- ) interesting random-item set-rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: bitmap
-
-VAR: last-line
-
-: run-rule ( -- )
-last-line> window-height [ drop step-capped-line dup ] map >bitmap >last-line
-.slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-random ( -- ) random-line >last-line run-rule ;
-
-: start-center ( -- ) center-line >last-line run-rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
-
-: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
-
-: (draw-bitmap) ( bitmap -- ) 0 swap [ >r dup r> draw-line 1+ ] each drop ;
-
-: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
-
-: display ( -- )
-GL_COLOR_BUFFER_BIT glClear black gl-color bitmap> draw-bitmap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( -- )
-<slate> >slate   namespace slate> set-slate-ns   [ display ] >action ;
-
-: init ( -- ) init-rule init-slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: loop-flag
-
-DEFER: loop
-
-: (loop) ( -- ) run-rule 3000 sleep loop ;
-
-: loop ( -- ) loop-flag> [ (loop) ] [ ] if ;
-
-: start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
-
-: stop-loop ( -- ) f >loop-flag ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: automata-gadget ;
-
-C: automata-gadget ( -- automata-gadget )
-init
-slate> over set-delegate
-interesting random-item set-rule ;
-
-: automata-window ( -- ) <automata-gadget> "Automata" open-titled-window ;
-
-automata-gadget H{
-    { T{ key-down f f "1" } [ slate-ns [ start-center    ] bind ] }
-    { T{ key-down f f "2" } [ slate-ns [ start-random    ] bind ] }
-    { T{ key-down f f "3" } [ slate-ns [ run-rule        ] bind ] }
-    { T{ key-down f f "5" }
-      [ slate-ns [ set-interesting start-center ] bind ] }
-    { T{ key-down f f "9" } [ slate-ns [ start-loop ] bind ] }
-    { T{ key-down f f "0" } [ slate-ns [ stop-loop ] bind ] }
-} set-gestures
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PROVIDE: apps/automata ;

apps/benchmarks/ack.factor

@@ -1,19 +0,0 @@
-USE: math
-USE: kernel
-USE: compiler
-USE: test
-
-! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
-
-: ack ( m n -- x )
-    over zero? [
-        nip 1+
-    ] [
-        dup zero? [
-            drop 1- 1 ack
-        ] [
-            dupd 1- ack >r 1- r> ack
-        ] if
-    ] if ;
-
-[ 4093 ] [ 3 9 ack ] unit-test

apps/benchmarks/continuations.factor

@@ -1,4 +0,0 @@
-IN: temporary
-USING: kernel sequences test ;
-
-[ ] [ 100000 [ drop [ continue ] callcc0 ] each ] unit-test

apps/benchmarks/empty-loop.factor

@@ -1,19 +0,0 @@
-IN: temporary
-USING: compiler kernel math math-internals sequences test ;
-
-: empty-loop-0 ( n -- )
-    dup 0 fixnum< [ drop ] [ 1 fixnum-fast empty-loop-0 ] if ;
-
-: empty-loop-1 ( n -- )
-    [ ] times ; 
-
-: empty-loop-2 ( n -- )
-    [ ] repeat ; 
-
-: empty-loop-3 ( n -- )
-    [ drop ] each ; 
-
-[ ] [ 5000000 empty-loop-0 ] unit-test
-[ ] [ 5000000 empty-loop-1 ] unit-test
-[ ] [ 5000000 empty-loop-2 ] unit-test
-[ ] [ 5000000 empty-loop-3 ] unit-test

apps/benchmarks/fac.factor

@@ -1,23 +0,0 @@
-IN: temporary
-USING: compiler kernel math sequences test ;
-
-: (fac) ( n! i -- n! )
-    dup zero? [
-        drop
-    ] [
-        [ * ] keep 1- (fac)
-    ] if ;
-
-: fac ( n -- n! )
-    1 swap (fac) ;
-
-: small-fac-benchmark
-    #! This tests fixnum math.
-    1 swap [ 10 fac 10 [ 1+ / ] each max ] times ;
-
-: big-fac-benchmark
-    10000 fac 10000 [ 1+ / ] each ;
-
-[ 1 ] [ big-fac-benchmark ] unit-test
-
-[ 1 ] [ 1000000 small-fac-benchmark ] unit-test

apps/benchmarks/fib.factor

@@ -1,66 +0,0 @@
-IN: temporary
-USE: compiler
-USE: kernel
-USE: math
-USE: test
-USE: math-internals
-USE: namespaces
-USE: words
-
-! Five fibonacci implementations, each one slower than the
-! previous.
-
-: fast-fixnum-fib ( m -- n )
-    dup 1 fixnum<= [
-        drop 1
-    ] [
-        1 fixnum-fast dup fast-fixnum-fib
-        swap 1 fixnum-fast fast-fixnum-fib fixnum+fast
-    ] if ;
-
-[ 9227465 ] [ 34 fast-fixnum-fib ] unit-test
-
-: fixnum-fib ( m -- n )
-    dup 1 fixnum<= [
-        drop 1
-    ] [
-        1 fixnum- dup fixnum-fib swap 1 fixnum- fixnum-fib fixnum+
-    ] if ;
-
-[ 9227465 ] [ 34 fixnum-fib ] unit-test
-
-: fib ( m -- n )
-    dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
-
-[ 9227465 ] [ 34 fib ] unit-test
-
-TUPLE: box i ;
-
-: tuple-fib ( m -- n )
-    dup box-i 1 <= [
-        drop 1 <box>
-    ] [
-        box-i 1- <box>
-        dup tuple-fib
-        swap
-        box-i 1- <box>
-        tuple-fib
-        swap box-i swap box-i + <box>
-    ] if ;
-
-[ T{ box f 9227465 } ] [ T{ box f 34 } tuple-fib ] unit-test
-
-SYMBOL: n
-: namespace-fib ( m -- n )
-    [
-        n set
-        n get 1 <= [
-            1
-        ] [
-            n get 1 - namespace-fib
-            n get 2 - namespace-fib
-            +
-        ] if
-    ] with-scope ;
-
-[ 1346269 ] [ 30 namespace-fib ] unit-test

apps/benchmarks/hashtables.factor

@@ -1,22 +0,0 @@
-IN: temporary
-USING: compiler hashtables kernel math memory namespaces
-sequences strings test ;
-
-: hash-bench-step ( hash elt -- )
-    3 random-int {
-        { [ dup 0 = ] [ drop dup rot set-hash ] }
-        { [ dup 1 = ] [ drop swap remove-hash ] }
-        { [ dup 2 = ] [ drop swap hash drop ] }
-    } cond ;
-
-: hashtable-benchmark ( seq -- )
-    10000 <hashtable> swap 10 [
-        drop
-        [
-            [
-                hash-bench-step
-            ] each-with
-        ] 2keep
-    ] each 2drop ;
-
-[ ] [ [ string? ] instances hashtable-benchmark ] unit-test

apps/benchmarks/help.factor

@@ -1,11 +0,0 @@
-USING: gadgets-panes hashtables help io kernel namespaces
-prettyprint sequences errors threads words test ;
-
-[
-    all-articles [
-        stdio get duplex-stream-out pane-stream-pane pane-clear
-        dup global [ . flush ] bind
-        [ dup help ] assert-depth drop
-        1 sleep
-    ] each
-] time

apps/benchmarks/iteration.factor

@@ -1,18 +0,0 @@
-IN: temporary
-USING: arrays compiler kernel kernel-internals math
-sequences strings test vectors sequences-internals ;
-
-: <range> ( from to -- seq ) dup <slice> ; inline
-
-: vector-iter 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
-: array-iter 100 [ 0 100000 <range> >array [ ] map drop ] times ;
-: string-iter 100 [ 0 100000 <range> >string [ ] map drop ] times ;
-: sbuf-iter 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ;
-: reverse-iter 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ;
-: dot-iter 100 [ 0 100000 <range> dup v. drop ] times ;
-
-[ ] [ vector-iter ] unit-test
-[ ] [ array-iter ] unit-test
-[ ] [ string-iter ] unit-test
-[ ] [ sbuf-iter ] unit-test
-[ ] [ reverse-iter ] unit-test

apps/benchmarks/load.factor

@@ -1,14 +0,0 @@
-PROVIDE: apps/benchmarks
-{ +tests+ {
-    "empty-loop.factor"
-    "fac.factor"
-    "fib.factor"
-    "sort.factor"
-    "continuations.factor"
-    "ack.factor"
-    "hashtables.factor"
-    "strings.factor"
-    "vectors.factor"
-    "prettyprint.factor"
-    "iteration.factor"
-} } ;

apps/benchmarks/prettyprint.factor

@@ -1,12 +0,0 @@
-IN: temporary
-USE: definitions
-USE: prettyprint
-USE: test
-USE: words
-USE: kernel
-USE: sequences
-USE: io
-
-[ ] [
-    [ vocabs [ words [ see ] each ] each ] string-out drop
-] unit-test

apps/benchmarks/reverse-complement.factor

@@ -1,58 +0,0 @@
-IN: temporary
-USING: compiler hashtables io kernel math math namespaces
-sequences strings vectors words words ;
-
-DEFER: trans-map
-
-: add-translation \ trans-map get set-nth ;
-
-[
-    256 0 <string> \ trans-map set
-    26 [ CHAR: A + dup add-translation ] each
-    26 [ dup CHAR: A + swap CHAR: a + add-translation ] each
-
-    "TGCAAKYRMBDHV"
-    "ACGTUMRYKVHDB"
-    2dup
-    [ add-translation ] 2each
-    [ ch>lower add-translation ] 2each
-    
-    \ trans-map get
-] with-scope
-
-\ trans-map swap unit define-compound
-\ trans-map t "inline" set-word-prop
-
-: translate-seq ( seq -- sbuf )
-    [
-        30000000 <sbuf> building set
-        <reversed> [ <reversed> % ] each
-        building get dup [ trans-map nth ] inject
-    ] with-scope ;
-
-SYMBOL: out
-
-: seg ( sbuf n -- str )
-    60 * dup 60 + pick length min rot <slice> >string ;
-
-: show-seq ( seq -- )
-    translate-seq dup length 59 + 60 /i
-    [ seg out get stream-print ] each-with ;
-
-: do-line ( seq line -- seq )
-    dup first ">;" memq? [
-        over show-seq out get stream-print dup delete-all
-    ] [
-        over push
-    ] if ;
-
-: (reverse-complement) ( seq -- )
-    readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
-
-: reverse-complement ( infile outfile -- )
-    <file-writer> [
-        stdio get out set
-        <file-reader> [
-            500000 <vector> (reverse-complement)
-        ] with-stream
-    ] with-stream ;

apps/benchmarks/sort.factor

@@ -1,7 +0,0 @@
-IN: temporary
-USING: compiler kernel math sequences test ;
-
-: sort-benchmark
-    100000 [ drop 100000 random-int ] map natural-sort drop ;
-
-[ ] [ sort-benchmark ] unit-test

apps/benchmarks/strings.factor

@@ -1,18 +0,0 @@
-USING: compiler kernel math namespaces sequences strings test ;
-
-! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
-
-: string-step ( n str -- )
-    2dup length > [
-        dup [ "123" % % "456" % % "789" % ] "" make
-        dup dup length 2 /i 0 swap rot subseq
-        swap dup length 2 /i 1+ 1 swap rot subseq append
-        string-step
-    ] [
-        2drop
-    ] if ;
-
-: string-benchmark ( n -- )
-    "abcdef" 10 [ 2dup string-step ] times 2drop ;
-
-[ ] [ 400000 string-benchmark ] unit-test

apps/benchmarks/vectors.factor

@@ -1,19 +0,0 @@
-USING: compiler kernel math sequences test vectors ;
-
-! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
-
-: fill-vector ( n -- vector )
-    dup <vector> swap [ dup pick set-nth ] each ;
-
-: copy-elt ( vec-y vec-x n -- )
-    #! Copy nth element from vec-x to vec-y.
-    rot >r tuck >r nth r> r> set-nth ;
-
-: copy-vector ( vec-y vec-x n -- )
-    #! Copy first n-1 elements from vec-x to vec-y.
-    [ [ >r 2dup r> copy-elt ] keep ] repeat 2drop ;
-
-: vector-benchmark ( n -- )
-    0 <vector> over fill-vector rot copy-vector ;
-
-[ ] [ 400000 vector-benchmark ] unit-test

apps/boids.factor

@@ -1,278 +0,0 @@
-REQUIRES: libs/math
-          libs/vars
-          apps/lindenmayer/opengl
-          libs/slate ;
-
-USING: kernel namespaces math sequences arrays threads opengl gadgets
-       math-contrib vars opengl-contrib slate ;
-
-IN: boids
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: boid pos vel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: boids
-VAR: world-size
-VAR: time-slice
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: cohesion-weight
-VAR: alignment-weight
-VAR: separation-weight
-
-VAR: cohesion-view-angle
-VAR: alignment-view-angle
-VAR: separation-view-angle
-
-VAR: cohesion-radius
-VAR: alignment-radius
-VAR: separation-radius
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-variables ( -- )
-1.0 >cohesion-weight
-1.0 >alignment-weight
-1.0 >separation-weight
-
-75 >cohesion-radius
-50 >alignment-radius
-25 >separation-radius
-
-180 >cohesion-view-angle
-180 >alignment-view-angle
-180 >separation-view-angle
-
-10 >time-slice ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! random-boid and random-boids
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-range ( a b -- n ) 1 + dupd swap - random-int + ;
-
-: random-pos ( -- pos ) world-size> [ random-int ] map ;
-
-: random-vel ( -- vel ) 2 >array [ drop -10 10 random-range ] map ;
-
-: random-boid ( -- boid ) random-pos random-vel <boid> ;
-
-: random-boids ( n -- boids ) [ drop random-boid ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! draw-boid
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: boid-point-a ( boid -- a ) boid-pos ;
-
-: boid-point-b ( boid -- b ) dup boid-pos swap boid-vel normalize 20 v*n v+ ;
-
-: boid-points ( boid -- point-a point-b ) dup boid-point-a swap boid-point-b ;
-
-: draw-line ( a b -- )
-GL_LINES glBegin first2 glVertex2i first2 glVertex2i glEnd ;
-
-: draw-boid ( boid -- ) boid-points draw-line ;
-
-: draw-boids ( -- ) boids> [ draw-boid ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: distance ( boid boid -- n ) boid-pos swap boid-pos v- norm ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: constrain ( n a b -- n ) rot min max ;
-
-: angle-between ( vec vec -- angle )
-2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: relative-position ( self other -- v ) boid-pos swap boid-pos v- ;
-
-: relative-angle ( self other -- angle )
-over boid-vel -rot relative-position angle-between ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
-
-: vaverage ( seq-of-vectors -- seq ) dup vsum swap length v/n ;
-
-: average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
-
-: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: within-radius? ( self other radius -- ? ) >r distance r> <= ;
-
-: within-view-angle? ( self other angle -- ? ) >r relative-angle r> 2 / <= ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: within-cohesion-radius? ( self other -- ? )
-  cohesion-radius get within-radius? ;
-
-: within-cohesion-view? ( self other -- ? )
-  cohesion-view-angle get within-view-angle? ;
-
-: within-cohesion-neighborhood? ( self other -- ? )
-  [ eq? not ] 2keep
-  [ within-cohesion-radius? ] 2keep
-  within-cohesion-view?
-  and and ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: within-separation-radius? ( self other -- ? )
-  separation-radius get within-radius? ;
-
-: within-separation-view? ( self other -- ? )
-  separation-view-angle get within-view-angle? ;
-
-: within-separation-neighborhood? ( self other -- ? )
-  [ eq? not ] 2keep
-  [ within-separation-radius? ] 2keep
-  within-separation-view?
-  and and ;  
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: within-alignment-radius? ( self other -- ? )
-  alignment-radius get within-radius? ;
-
-: within-alignment-view? ( self other -- ? )
-  alignment-view-angle get within-view-angle? ;
-
-: within-alignment-neighborhood? ( self other -- ? )
-  [ eq? not ] 2keep
-  [ within-alignment-radius? ] 2keep
-  within-alignment-view?
-  and and ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cohesion-neighborhood ( self -- boids )
-boids> [ within-cohesion-neighborhood? ] subset-with ;
-
-: cohesion-force ( self -- force )
-dup cohesion-neighborhood
-dup length 0 =
-[ 2drop { 0 0 } ]
-[ average-position swap boid-pos v- normalize cohesion-weight> v*n ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: separation-neighborhood ( self -- boids )
-boids> [ within-separation-neighborhood? ] subset-with ;
-
-: separation-force ( self -- force )
-dup separation-neighborhood
-dup length 0 =
-[ 2drop { 0 0 } ]
-[ average-position swap boid-pos swap v- normalize separation-weight> v*n ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: alignment-neighborhood ( self -- boids )
-boids> [ within-alignment-neighborhood? ] subset-with ;
-
-: alignment-force ( self -- force )
-alignment-neighborhood
-dup length 0 =
-[ drop { 0 0 } ]
-[ average-velocity normalize alignment-weight get v*n ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! F = m a
-!
-! We let m be equal to 1 so then this is simply: F = a
-
-: acceleration ( boid -- acceleration )
-  dup dup
-  separation-force rot
-  alignment-force  rot
-  cohesion-force v+ v+ ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! iterate-boid
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: world-width ( -- w ) world-size> first ;
-
-: world-height ( -- w ) world-size> second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: below? ( n a b -- ? ) drop < ;
-
-: above? ( n a b -- ? ) nip > ;
-
-: wrap ( n a b -- n )
-{ { [ 3dup below? ]
-    [ 2nip ] }
-  { [ 3dup above? ]
-    [ drop nip ] }
-  { [ t ]
-    [ 2drop ] } }
-cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: wrap-x ( x -- x ) 0 world-width 1- wrap ;
-
-: wrap-y ( y -- y ) 0 world-height 1- wrap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new-pos ( boid -- pos ) dup boid-vel time-slice> v*n swap boid-pos v+ ;
-
-: new-vel ( boid -- vel )
-dup acceleration time-slice> v*n swap boid-vel v+ normalize ;
-
-: wrap-pos ( pos -- pos ) first2 wrap-y swap wrap-x swap 2array ;
-
-: iterate-boid ( self -- self ) dup >r new-pos wrap-pos r> new-vel <boid> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-boids ( -- ) boids> [ iterate-boid ] map >boids ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: display ( -- ) GL_COLOR_BUFFER_BIT glClear black gl-color draw-boids ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: stop?
-
-: run ( -- )
-slate> rect-dim >world-size
-iterate-boids .slate 1 sleep
-stop? get [ ] [ run ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( -- )
-<slate> >slate
-namespace slate> set-slate-ns
-[ display ] >action
-slate> "Boids" open-titled-window ;
-
-: init-boids ( -- ) 50 random-boids >boids ;
-
-: init-world-size ( -- ) { 100 100 } >world-size ;
-
-: init ( -- ) init-slate init-variables init-world-size init-boids stop? off ;
-
-PROVIDE: apps/boids ;

apps/factorbot.factor

@@ -1,108 +0,0 @@
-! Simple IRC bot written in Factor.
-
-REQUIRES: libs/httpd ;
-
-USING: errors generic hashtables help html http io kernel math
-memory namespaces parser prettyprint sequences strings threads
-words ;
-IN: factorbot
-
-SYMBOL: irc-stream
-SYMBOL: nickname
-SYMBOL: speaker
-SYMBOL: receiver
-
-: irc-write ( s -- ) irc-stream get stream-write ;
-: irc-print ( s -- )
-    irc-stream get stream-print
-    irc-stream get stream-flush ;
-
-: nick ( nick -- )
-    dup nickname set  "NICK " irc-write irc-print ;
-
-: login ( nick -- )
-    dup nick
-    "USER " irc-write irc-write
-    " hostname servername :irc.factor" irc-print ;
-
-: connect ( server -- ) 6667 <client> irc-stream set ;
-
-: disconnect ( -- ) irc-stream get stream-close ;
-
-: join ( chan -- )
-    "JOIN " irc-write irc-print ;
-
-GENERIC: handle-irc ( line -- )
-PREDICATE: string privmsg " " split1 nip "PRIVMSG" head? ;
-PREDICATE: string ping "PING" head? ;
-
-M: object handle-irc ( line -- )
-    drop ;
-
-: parse-privmsg ( line -- text )
-    " " split1 nip
-    "PRIVMSG " ?head drop
-    " " split1 swap receiver set
-    ":" ?head drop ;
-
-M: privmsg handle-irc ( line -- )
-    parse-privmsg
-    " " split1 swap
-    "factorbot-commands" lookup dup
-    [ execute ] [ 2drop ] if ;
-
-M: ping handle-irc ( line -- )
-    "PING " ?head drop "PONG " swap append irc-print ;
-
-: parse-irc ( line -- )
-    ":" ?head [ "!" split1 swap speaker set ] when handle-irc ;
-
-: say ( line nick -- )
-    "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
-
-: respond ( line -- )
-    receiver get nickname get = speaker receiver ? get say ;
-
-: irc-loop ( -- )
-    irc-stream get stream-readln
-    [ dup print flush parse-irc irc-loop ] when* ;
-
-: factorbot
-    "irc.freenode.net" connect
-    "factorbot" login
-    "#concatenative" join
-    [ irc-loop ] [ irc-stream get stream-close ] cleanup ;
-
-: factorbot-loop [ factorbot ] try 30000 sleep factorbot-loop ;
-
-: multiline-respond ( string -- )
-    string-lines [ respond ] each ;
-
-: object-href
-    "http://factorcode.org" swap browser-link-href append ;
-
-: not-found ( str -- )
-    "Sorry, I couldn't find anything for " swap append respond ;
-
-IN: factorbot-commands
-
-: see ( text -- )
-    dup words-named dup empty? [
-        drop
-        not-found
-    ] [
-        nip [
-            dup summary " -- " 
-            rot object-href 3append respond
-        ] each
-    ] if ;
-
-: memory ( text -- )
-    drop [ room. ] string-out multiline-respond ;
-
-: quit ( text -- )
-    drop speaker get "slava" = [ disconnect ] when ;
-
-PROVIDE: apps/factorbot ;
-
-MAIN: apps/factorbot factorbot ;

apps/factory/README.txt

@@ -1,29 +0,0 @@
-----------------------------------------------------------------------
-Running factory in Xnest
-----------------------------------------------------------------------
-
-In a terminal, run Xnest using an unused display number. Usually you
-can use 2 or greater.
-
-  $ Xnest -auth /dev/null :2
-
-Start factor and launch factory on the appropriate display:
-
-  "libs/factory" run-module
-
-In a terminal, start an application on the appropriate display:
-
-  $ DISPLAY=:2 xterm
-
-----------------------------------------------------------------------
-The mouse functions
-----------------------------------------------------------------------
-
-Root window
-Mouse-1		Toggle root menu
-Mouse-2		Toggle window list
-
-Window border
-Mouse-1		Drag to move window
-Mouse-2		Drag to resize window (specify bottom right corner)
-Mouse-3		Hide window (use window list to get it back)

apps/factory/factory.factor

@@ -1,657 +0,0 @@
-USING: kernel alien compiler namespaces generic math sequences hashtables io
-arrays words prettyprint concurrency process
-vars rectangle x11 x concurrent-widgets ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: workspace-menu
-DEFER: wm-frame?
-DEFER: manage-window
-DEFER: window-list
-DEFER: refresh-window-list
-DEFER: layout-frame
-DEFER: mapped-windows
-DEFER: workspace-1 DEFER: workspace-2 DEFER: workspace-3 DEFER: workspace-4
-DEFER: switch-to
-DEFER: update-title
-DEFER: delete-frame
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: popup-window ( -- ) mouse-sensor move-window raise-window map-window ;
-
-: popup-window% [ popup-window ] with-window-object ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: root-menu
-
-: setup-root-menu ( -- )
-  create-menu root-menu set
-  "black" lookup-color root-menu get set-window-background%
-  "Terminal" [ "xterm &" system ] root-menu get add-popup-menu-item
-  "Emacs"    [ "emacs &" system ]          root-menu get add-popup-menu-item
-  "Firefox"  [ "firefox &" system ]        root-menu get add-popup-menu-item
-  "Workspaces"
-    [ workspace-menu get popup-window% ] root-menu get add-popup-menu-item ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: drag-gc
-
-: make-drag-gc ( -- GC )
-create-gc dup
-[ IncludeInferiors set-subwindow-mode
-  GXxor set-function
-  white-pixel get set-foreground ] with-gcontext ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VARS: event frame push position ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: event-type ( -- type ) event> XAnyEvent-type ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: drag-offset ( -- offset ) position> push> v- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-rubber-band ( <rect> -- )
-root get [ drag-gc get [ draw-rect ] with-gcontext ] with-win ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! drag-move-frame
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-frame-outline ( -- )
-drag-offset frame> window-position% v+ frame> window-size% <rect>
-draw-rubber-band ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: drag-move-frame-loop ( -- )
-next-event >event
-{ { [ event-type MotionNotify = ]
-    [ draw-frame-outline
-      event> XMotionEvent-root-position >position
-      draw-frame-outline
-      drag-move-frame-loop ] }
-  { [ event-type ButtonRelease = ]
-    [ draw-frame-outline
-      drag-offset frame> window-position% v+   frame> move-window% ] }
-  { [ t ]
-    [ "[drag-move-frame-loop] Ignoring event type: " write
-      event-type event-type>name write terpri flush
-      drag-move-frame-loop ] } }
-cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: drag-move-frame ( event <wm-frame> -- )
-[ >frame >event
-  event> XButtonEvent-root-position >push
-  event> XButtonEvent-root-position >position
-  draw-frame-outline
-  drag-move-frame-loop
-  frame> raise-window% ]
-with-scope ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! drag-size-frame
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-size-outline ( -- )
-frame> window-position% position> over v- <rect> draw-rubber-band ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: drag-size-frame-loop ( -- )
-next-event >event
-{ { [ event-type MotionNotify = ]
-    [ draw-size-outline
-      event> XMotionEvent-root-position >position
-      draw-size-outline
-      drag-size-frame-loop ] }
-  { [ event-type ButtonRelease = ]
-    [ draw-size-outline
-      position> frame> window-position% v- frame> resize-window%
-      frame> layout-frame ] }
-  { [ t ]
-    [ "[drag-size-frame-loop] ignoring event" print flush
-      drag-size-frame-loop ] } }
-cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: drag-size-frame ( event <wm-frame> -- )
-[ >frame >event
-  event> XButtonEvent-root-position >position
-  draw-size-outline
-  drag-size-frame-loop ]
-with-scope ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: move-request-x
-GENERIC: move-request-y
-GENERIC: move-request-position
-GENERIC: execute-move-request
-GENERIC: size-request-width
-GENERIC: size-request-height
-GENERIC: size-request-size
-GENERIC: execute-size-request
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! wm-root
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: wm-root ;
-
-: wm-root-mask ( -- mask )
-[ SubstructureRedirectMask
-  SubstructureNotifyMask
-  ButtonPressMask
-  ButtonReleaseMask
-  KeyPressMask
-  KeyReleaseMask ] bitmask ;
-
-: create-wm-root ( window-id -- <wm-root> )
-dpy get swap <window> <wm-root> tuck set-delegate dup add-to-window-table
-wm-root-mask over select-input% ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! M: wm-root handle-map-request-event
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: id>obj ( id -- obj )
-dup window-table get hash dup [ nip ] [ drop dpy get swap <window> ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-root handle-map-request-event ( event <wm-root> -- )
-"handle-map-request-event called on wm-root" print flush
-  drop XMapRequestEvent-window id>obj				! obj
-
-  { { [ dup wm-frame? ]
-      [ map-window% ] }
-
-    { [ dup valid-window?% not ]
-      [ "Not a valid window." print flush drop ] }
-
-    { [ dup window-override-redirect% 1 = ]
-      [ "Not reparenting: " print 
-        "new window has override_redirect attribute set." print flush
-        drop ] }
-
-    { [ dup window-id window-parent+ id>obj wm-frame? ]
-      [ "Window is already managed" print flush drop ] }
-
-    { [ t ] [ window-id manage-window ] } }
-
-  cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Words for working with an XConfigureRequestEvent
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bit-test ( a b -- t-or-f ) bitand 0 = not ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: move-request-x? ( event -- ) XConfigureRequestEvent-value_mask CWX bit-test ;
-: move-request-y? ( event -- ) XConfigureRequestEvent-value_mask CWY bit-test ;
-
-: move-request? ( event -- ? ) dup move-request-x? swap move-request-y? or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: size-request-width? ( event -- )
-  XConfigureRequestEvent-value_mask CWWidth bit-test ;
-
-: size-request-height? ( event -- )
-  XConfigureRequestEvent-value_mask CWHeight bit-test ;
-
-: size-request? ( event -- )
-  dup size-request-width? swap size-request-height? or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! M: wm-root handle-configure-request-event
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-root move-request-x ( event wm-root -- x )
-  drop
-  dup move-request-x?
-  [ XConfigureRequestEvent-x ]
-  [ XConfigureRequestEvent-window [ window-x ] with-win ]
-  if ;
-
-M: wm-root move-request-y ( event wm-root -- y )
-  drop
-  dup move-request-y?
-  [ XConfigureRequestEvent-y ]
-  [ XConfigureRequestEvent-window [ window-y ] with-win ]
-  if ;
-
-M: wm-root move-request-position ( event wm-root -- { x y } )
-  2dup move-request-x -rot move-request-y 2array ;
-
-M: wm-root execute-move-request ( event wm-root -- )
-  dupd move-request-position swap XConfigureRequestEvent-window move-window+ ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-root size-request-width ( event wm-root -- width )
-  drop
-  dup size-request-width?
-  [ XConfigureRequestEvent-width ]
-  [ XConfigureRequestEvent-window [ window-width ] with-win ]
-  if ;
-
-M: wm-root size-request-height ( event wm-root -- height )
-  drop 
-  dup size-request-height?
-  [ XConfigureRequestEvent-height ]
-  [ XConfigureRequestEvent-window [ window-height ] with-win ]
-  if ;
-
-M: wm-root size-request-size ( event wm-root -- { width height } )
-  2dup size-request-width -rot size-request-height 2array ;
-
-M: wm-root execute-size-request ( event wm-root -- )
-  dupd size-request-size swap XConfigureRequestEvent-window resize-window+ ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-root handle-configure-request-event ( event wm-root -- )
-  over move-request? [ 2dup execute-move-request ] when
-  over size-request? [ 2dup execute-size-request ] when
-  drop drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! M: wm-root handle-button-press-event
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: XButtonEvent-position ( event -- { x y } )
-  dup XButtonEvent-x swap XButtonEvent-y 2array ;
-
-: XButtonEvent-root-position ( event -- { x y } )
-  dup XButtonEvent-x_root swap XButtonEvent-y_root 2array ;
-
-M: wm-root handle-button-press-event ( event wm-root -- )
-  drop						! event
-
-  { { [ dup XButtonEvent-button Button1 = ]
-      [ root-menu get window-map-state% IsUnmapped =
-        [ XButtonEvent-root-position root-menu get move-window%
-          root-menu get raise-window%
-          root-menu get map-window% ]
-        [ root-menu get unmap-window% ]
-        if ] }
-
-    { [ dup XButtonEvent-button Button2 = ]
-      [ window-list get window-map-state% IsUnmapped =
-        [ XButtonEvent-root-position window-list get move-window%
-          window-list get raise-window%
-          window-list get refresh-window-list
-          window-list get map-window% ]
-        [ window-list get unmap-window% ]
-        if ] }
-
-    { [ t ] [ "Button has no function on root window." print flush drop ] } }
-
-  cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! M: wm-root handle-key-press-event
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: True 1 ;
-: False 0 ;
-
-: f1-keycode ( -- code ) 67 ;
-: f2-keycode ( -- code ) 68 ;
-: f3-keycode ( -- code ) 69 ;
-: f4-keycode ( -- code ) 70 ;
-
-: grab-keys ( -- )
-f1-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
-f2-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
-f3-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
-f4-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key ;
-
-M: wm-root handle-key-press-event ( event wm-root -- )
-drop
-{ { [ dup XKeyEvent-keycode f1-keycode = ] [ workspace-1 get switch-to ] }
-  { [ dup XKeyEvent-keycode f2-keycode = ] [ workspace-2 get switch-to ] }
-  { [ dup XKeyEvent-keycode f3-keycode = ] [ workspace-3 get switch-to ] }
-  { [ dup XKeyEvent-keycode f4-keycode = ] [ workspace-4 get switch-to ] }
-  { [ t ] [ "wm-root ignoring key press" print drop ] } } cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: wm-child ;
-
-: create-wm-child ( window-id -- <wm-child> )
-dpy get swap <window> <wm-child> tuck set-delegate dup add-to-window-table ;
-
-M: wm-child handle-property-event ( event <wm-child> -- )
-  "A <wm-child> received a property event" print flush
-  nip
-  window-parent% window-table get hash dup [ update-title ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: wm-frame child ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: wm-frame-mask ( -- mask )
-[ SubstructureRedirectMask
-  SubstructureNotifyMask
-  ExposureMask
-  ButtonPressMask
-  ButtonReleaseMask
-  PointerMotionMask
-  EnterWindowMask ] bitmask ;
-
-: create-wm-frame ( <wm-child> -- <wm-frame> )
-<wm-frame> create-window-object over set-delegate dup add-to-window-table
-wm-frame-mask over select-input% ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: update-title ( <wm-frame> -- )
-dup clear-window%
-{ 5 1 } swap dup wm-frame-child fetch-name% swap draw-string-top-left% ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VARS: child frame button ;
-
-: manage-window ( window -- )
-flush-dpy grab-server flush-dpy
-create-wm-child dup create-wm-frame
-[ child frame ]
-[ "cornflowerblue" lookup-color frame> set-window-background%
-  child> add-to-save-set%
-  child> window-position% frame> move-window%
-  0 child> set-window-border-width%
-  frame> child> reparent-window%
-  child> window-size% { 10 20 } v+ frame> resize-window%
-  { 5 15 } child> move-window%
-  "" frame> [ delete-frame ] curry create-button
-  [ button ]
-  [ frame> button> reparent-window%
-    { 9 9 } button> resize-window%
-    frame> window-width% 9 - 5 - 3 2array button> move-window%
-    NorthEastGravity button> set-window-gravity%
-    black-pixel get button> set-window-background% ]
-  let
-  PropertyChangeMask child> select-input%
-  frame> map-subwindows%
-  frame> map-window%
-  frame> update-title
-  flush-dpy 0 sync-dpy ungrab-server flush-dpy ]
-let ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: destroy-window-event-match? ( event <wm-frame> -- ? )
-window-id swap XDestroyWindowEvent-window = ;
-
-M: wm-frame handle-destroy-window-event ( event <wm-frame> -- )
-2dup destroy-window-event-match? [ destroy-window% drop ] [ 2drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: map-request-event-match? ( event <wm-frame> -- ? )
-  window-id swap XMapRequestEvent-window = ;
-
-M: wm-frame handle-map-request-event ( event <wm-frame> -- )
-  2dup map-request-event-match?				! event frame ?
-  [ dup wm-frame-child map-window% map-window% drop ] [ drop drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: map-event-match? ( event <wm-frame> -- ? )
-window-id swap XMapEvent-window = ;
-
-M: wm-frame handle-map-event ( event <wm-frame> -- )
-  2dup map-event-match?
-  [ dup map-window% raise-window% drop ] [ drop drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! M: wm-frame handle-configure-request-event ( event frame )
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-frame move-request-x ( event frame -- x )
-  over move-request-x?
-  [ drop XConfigureRequestEvent-x ]
-  [ nip window-x% ]
-  if ;
-
-M: wm-frame move-request-y ( event frame -- y )
-  over move-request-y?
-  [ drop XConfigureRequestEvent-y ]
-  [ nip window-y% ]
-  if ;
-
-M: wm-frame move-request-position ( event frame -- { x y } )
-  2dup move-request-x -rot move-request-y 2array ;
-
-M: wm-frame execute-move-request ( event frame -- )
-  dup -rot move-request-position swap move-window% ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-frame size-request-width ( event frame -- width )
-  over size-request-width?
-  [ drop XConfigureRequestEvent-width ]
-  [ nip wm-frame-child window-width% ]
-  if ;
-
-M: wm-frame size-request-height ( event frame -- height )
-  over size-request-height?
-  [ drop XConfigureRequestEvent-height ]
-  [ nip wm-frame-child window-height% ]
-  if ;
-
-M: wm-frame size-request-size ( event frame -- size )
-  2dup size-request-width -rot size-request-height 2array ;
-
-: execute-size-request/child ( event frame -- )
-  dup wm-frame-child -rot size-request-size swap resize-window% ;
-
-: execute-size-request/frame ( event frame -- )
-  dup -rot size-request-size { 10 20 } v+ swap resize-window% ;
-
-M: wm-frame execute-size-request ( event frame -- )
-  2dup execute-size-request/child execute-size-request/frame ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-frame handle-configure-request-event ( event frame -- )
-  over move-request? [ 2dup execute-move-request ] when
-  over size-request? [ 2dup execute-size-request ] when
-  drop drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: unmap-event-match? ( event frame -- ? )
-  wm-frame-child window-id swap XUnmapEvent-window = ;
-
-M: wm-frame handle-unmap-event ( event frame -- )
-  2dup unmap-event-match? [ unmap-window% drop ] [ drop drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-frame handle-button-press-event ( event frame -- )
-  over XButtonEvent-button				! event frame button
-  { { [ dup Button1 = ] [ drop drag-move-frame ] }
-    { [ dup Button2 = ] [ drop drag-size-frame ] }
-    { [ dup Button3 = ] [ drop nip unmap-window% ] }
-    { [ t ] [ drop drop drop ] } }
-  cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-frame handle-enter-window-event ( event frame -- )
-  nip dup wm-frame-child valid-window?%
-  [ wm-frame-child >r RevertToPointerRoot CurrentTime r> set-input-focus% ]
-  [ destroy-window% ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-frame handle-property-event ( event frame -- )
-"Inside handle-property-event" print flush 2drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: wm-frame handle-expose-event ( event frame -- )
-nip dup clear-window% update-title ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: frame-position-child ( frame -- ) wm-frame-child { 5 15 } swap move-window% ;
-
-: frame-fit-child ( frame -- )
-dup window-size% { 10 20 } v- swap wm-frame-child resize-window% ;
-
-: layout-frame ( frame -- ) dup frame-position-child frame-fit-child ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: WM_PROTOCOLS
-SYMBOL: WM_DELETE_WINDOW
-
-: delete-frame ( frame -- ) wm-frame-child window-id
-[ WM_PROTOCOLS get WM_DELETE_WINDOW get send-client-message ] with-win ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Workspaces
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: switch-to
-
-SYMBOL: current-workspace
-
-TUPLE: workspace windows ;
-
-: create-workspace [ ] <workspace> ;
-
-M: workspace switch-to ( workspace -- )
-  mapped-windows dup current-workspace get set-workspace-windows
-  [ unmap-window+ ] each
-  dup workspace-windows [ map-window+ ] each
-  current-workspace set-global ;
-
-SYMBOL: workspace-1
-SYMBOL: workspace-2
-SYMBOL: workspace-3
-SYMBOL: workspace-4
-
-create-workspace workspace-1 set-global
-create-workspace workspace-2 set-global
-create-workspace workspace-3 set-global
-create-workspace workspace-4 set-global
-
-workspace-1 get current-workspace set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: workspace-menu
-
-: setup-workspace-menu ( -- )
-  create-menu workspace-menu set
-  "black" lookup-color workspace-menu get set-window-background%
-  "Workspace 1"
-    [ workspace-1 get switch-to ] workspace-menu get add-popup-menu-item
-  "Workspace 2"
-    [ workspace-2 get switch-to ] workspace-menu get add-popup-menu-item
-  "Workspace 3"
-    [ workspace-3 get switch-to ] workspace-menu get add-popup-menu-item
-  "Workspace 4"
-    [ workspace-4 get switch-to ] workspace-menu get add-popup-menu-item ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: invalid-frame? ( <wm-frame> -- ? )
-wm-frame-child window-id valid-window?+ not ;
-
-: remove-invalid-frames ( -- )
-window-table get hash-values [ wm-frame? ] subset [ invalid-frame? ] subset
-[ window-id window-table get remove-hash ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! window-list
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: window-list
-
-: setup-window-list ( -- )
-  create-menu window-list set-global
-  "black" lookup-color window-list get set-window-background%
-  300 window-list get set-menu-item-width ;
-
-: not-transient? ( frame -- ? ) wm-frame-child get-transient-for-hint% not ;
-
-: add-window-to-list ( window-list frame -- window-list )
-  dup				! window-list frame frame
-  wm-frame-child		! window-list frame child
-  fetch-name%			! window-list frame name-or-f
-  dup				! window-list frame name-or-f name-or-f
-  [ ] [ drop "*untitled*" ] if	! window-list frame name
-  swap				! window-list name frame
-  [ map-window% ]		! window-list name frame [ map-window% ]
-  curry				! window-list name action
-  pick				! window-list name action window-list
-  add-popup-menu-item ;
-
-: refresh-window-list ( window-list -- )
-  dup window-children% [ destroy-window+ ] each
-  clean-window-table
-  remove-invalid-frames
-  window-table get hash-values [ wm-frame? ] subset
-  [ not-transient? ] subset
-  [ add-window-to-list ] each
-  drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: window-is-mapped? ( window -- ? ) window-map-state+ IsUnmapped = not ;
-
-: mapped-windows ( -- [ a b c d ... ] )
-  root get window-children+ [ window-is-mapped? ] subset ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: manage-existing-windows ( -- ) mapped-windows [ manage-window ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-factory ( dpy-string -- )
-  initialize-x
-  [ "X11 : error-handler called" print flush ] set-error-handler
-  root get [ make-drag-gc ] with-win drag-gc set
-  root get [ black-pixel get set-window-background clear-window ] with-win
-  root get create-wm-root
-  root get [ grab-keys ] with-win
-  "WM_PROTOCOLS" False intern-atom WM_PROTOCOLS set
-  "WM_DELETE_WINDOW" False intern-atom WM_DELETE_WINDOW set
-  "cornflowerblue" lookup-color menu-enter-color set
-  "white" lookup-color menu-leave-color set
-  setup-root-menu
-  setup-window-list
-  setup-workspace-menu
-  manage-existing-windows
-  [ concurrent-event-loop ] spawn ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: shells USE: listener : factory f start-factory listener ;

apps/factory/load.factor

@@ -1,7 +0,0 @@
-REQUIRES: libs/process libs/concurrency libs/x11 libs/vars ;
-
-PROVIDE: apps/factory { +files+ {  "factory.factor" } } ;
-
-USE: factory
-
-MAIN: apps/factory f start-factory ;

apps/furnace-fjsc/furnace-fjsc.factor

@@ -1,76 +0,0 @@
-! Copyright (C) 2006 Chris Double. All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-IN: furnace:fjsc
-USING: kernel html furnace xml io httpd sequences 
-       namespaces file-responder parser-combinators lazy-lists
-       fjsc  ;
-
-: script ( path -- )
-  #! given a path to a javascript file, output the 
-  #! script tag that references it.
-  <script "text/javascript" =type =src script> </script> ;
-
-: fjsc-page ( scripts title quot -- )
-  #! Display a web page importing the given script
-  #! tags and using the title. The body of the page
-  #! is generated by calling the quotation.
-  -rot xhtml-preamble
-  chars>entities
-  <html " xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\"" write-html html>
-    <head>
-      <title> write </title>
-      [ script ] each
-    </head>
-    <body>
-     call
-    </body>
-  </html> ;
-  
-: fjsc-render ( template title -- )
-  #! Render the fjsc page importing the required
-  #! scripts.
-  serving-html {
-    "/responder/fjsc-resources/jquery.js"
-    "/responder/fjsc-resources/bootstrap.js"
-  } swap [
-    [
-      f swap render-template
-    ] fjsc-page
-  ] with-html-stream ;
-
-: compile ( code -- )
-  #! Compile the facor code as a string, outputting the http
-  #! response containing the javascript.
-  serving-text
-  'expression' parse car parse-result-parsed fjsc-compile 
-   write flush ;
-
-! The 'compile' action results in an URL that looks like
-! 'responder/fjsc/compile'. It takes one query or post 
-! parameter called 'code'. It calls the 'compile' word
-! passing the parameter to it on the stack.
-\ compile { 
-  { "code" v-required } 
-} define-action
-
-: repl ( -- )
-  #! The main 'repl' page.
-  f "repl" "Factor to Javascript REPL" fjsc-render ;
-
-! An action called 'repl' 
-\ repl { } define-action
-
-! Create the web app, providing access 
-! under '/responder/fjsc' which calls the
-! 'repl' action.
-"fjsc" "repl" "apps/furnace-fjsc" web-app
-
-! An URL to the javascript resource files used by
-! the 'fjsc' responder.
-"fjsc-resources" [
- [
-   "libs/fjsc/resources/" resource-path "doc-root" set
-   file-responder
- ] with-scope
-] add-simple-responder

apps/furnace-fjsc/load.factor

@@ -1,18 +0,0 @@
-! Copyright (C) 2006 Chris Double. All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-REQUIRES: libs/furnace libs/fjsc ;
-
-PROVIDE: apps/furnace-fjsc 
-{ 
-  +files+ { 
-  "furnace-fjsc.factor"
-  } 
-} {
-  +tests+ { 
-  }
-} { 
-  +help+ 
-  { 
-  } 
-} ;

apps/furnace-fjsc/repl.fhtml

@@ -1,41 +0,0 @@
-<table border="0">
-<tr><td valign="top">
-<p><b>Enter Factor Code Here</b></p>
-<form id="toeval" onsubmit="factor.server_eval($('#code').get(0).value);return false;" method="post">
-  <textarea name="code" id="code" cols="64" rows="5">
-  </textarea>
-  <input type="submit" value="Compile"/>
-</form>
-<h3>Compiled Code</h3>
-<textarea id="compiled" cols="64" rows="3">
-</textarea>
-<p><b>Stack</b></p>
-<div id="stack">
-</div>
-<p><b>Playground</b></p>
-<div id="playground">
-</div>
-</td>
-<td valign="top">
-<p>More information on the Factor to Javascript compiler can be found at these blog posts:
-<ul>
-<li><a href="http://www.bluishcoder.co.nz/2006/12/compiling-factor-to-javascript.html">Factor to Javascript Compiler</a></li>
-<li><a href="http://www.bluishcoder.co.nz/2006/12/factor-to-javascript-compiler-updates.html">Factor to Javascript Compiler Updates</a></li>
-<li><a href="http://www.bluishcoder.co.nz/2006/12/continuations-added-to-fjsc.html">Continuations added to fjsc</a></li>
-<li><a href="http://www.bluishcoder.co.nz/2006/12/cross-domain-json-with-fjsc.html">Cross Domain JSON with fjsc</a></li>
-</ul>
-</p>
-<p>Some useful words:
-<dl>
-<dt>vocabs ( -- seq )</dt>
-<dd>Return a sequence of available vocabularies</dd>
-<dt>words ( string -- seq )</dt>
-<dd>Return a sequence of words in the given vocabulary</dd>
-<dt>all-words ( -- seq )</dt>
-<dd>Return a sequence of all words</dd>
-</dl>
-</p>
-<p>The contents of <a href="/responder/fjsc-resources/bootstrap.factor">bootstrap.factor</a> have been loaded on startup.</p>
-</td>
-</tr>
-</table>

apps/furnace-pastebin/annotate-paste.fhtml

@@ -1,28 +0,0 @@
-<% USING: namespaces math io ; %>
-
-<h1>Annotate</h1>
-
-<form method="POST" action="/responder/pastebin/annotate-paste">
-
-<table>
-
-<input type="hidden" name="n" value="<% "n" get number>string write %>" />
-
-<tr>
-<th>Summary:</th>
-<td><input type="TEXT" name="summary" value="" /></td>
-</tr>
-
-<tr>
-<th>Your name:</th>
-<td><input type="TEXT" name="author" value="" /></td>
-</tr>
-
-<tr>
-<th valign="top">Contents:</th>
-<td><textarea rows="24" cols="60" name="contents"></textarea></td>
-</tr>
-</table>
-
-<input type="SUBMIT" value="Annotate" />
-</form>

apps/furnace-pastebin/annotation.fhtml

@@ -1,11 +0,0 @@
-<% USING: namespaces io ; %>
-
-<h2>Annotation: <% "summary" get write %></h2>
-
-<table>
-<tr><th>Annotation by:</th><td><% "author" get write %></td></tr>
-<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
-<tr><th>Created:</th><td><% "date" get write %></td></tr>
-</table>
-
-<pre><% "contents" get write %></pre>

apps/furnace-pastebin/load.factor

@@ -1,4 +0,0 @@
-REQUIRES: libs/furnace ;
-
-PROVIDE: apps/furnace-pastebin
-{ +files+ {  "pastebin.factor" } } ;

apps/furnace-pastebin/new-paste.fhtml

@@ -1,27 +0,0 @@
-<form method="POST" action="/responder/pastebin/submit-paste">
-
-<table>
-
-<tr>
-<th>Summary:</th>
-<td><input type="TEXT" name="summary" value="" /></td>
-</tr>
-
-<tr>
-<th>Your name:</th>
-<td><input type="TEXT" name="author" value="" /></td>
-</tr>
-
-<tr>
-<th>Channel:</th>
-<td><input type="TEXT" name="channel" value="" /></td>
-</tr>
-
-<tr>
-<th valign="top">Contents:</th>
-<td><textarea rows="24" cols="60" name="contents"></textarea></td>
-</tr>
-</table>
-
-<input type="SUBMIT" value="Submit paste" />
-</form>

apps/furnace-pastebin/paste-list.fhtml

@@ -1,7 +0,0 @@
-<% USING: namespaces furnace sequences ; %>
-
-<table>
-<tr><th>Summary:</th><th>Paste by:</th></tr>
-<% "pastes" get [ "paste-summary" render-template ] each %></table>
-
-<% "new-paste-quot" get "New paste" render-link %>

apps/furnace-pastebin/paste-summary.fhtml

@@ -1,7 +0,0 @@
-<% USING: namespaces io kernel math furnace ; %>
-
-<tr>
-<td><% "summary" get write %></td>
-<td><% "author" get write %></td>
-<td><% "n" get number>string "show-paste-quot" get curry "Show" render-link %></td>
-</tr>

apps/furnace-pastebin/pastebin.factor

@@ -1,75 +0,0 @@
-IN: furnace:pastebin
-USING: calendar kernel namespaces sequences furnace hashtables
-math ;
-
-TUPLE: paste n summary author channel contents date annotations ;
-
-TUPLE: annotation summary author contents ;
-
-C: paste ( summary author channel contents -- paste )
-    V{ } clone over set-paste-annotations
-    [ set-paste-contents ] keep
-    [ set-paste-author ] keep
-    [ set-paste-channel ] keep
-    [ set-paste-summary ] keep ;
-
-TUPLE: pastebin pastes ;
-
-C: pastebin ( -- pastebin )
-    V{ } clone over set-pastebin-pastes ;
-
-: add-paste ( paste pastebin -- )
-    now timestamp>http-string pick set-paste-date
-    dup pastebin-pastes length pick set-paste-n
-    pastebin-pastes push ;
-
-<pastebin> pastebin set-global
-
-: get-paste ( n -- paste )
-    pastebin get pastebin-pastes nth ;
-
-: show-paste ( n -- )
-    get-paste "show-paste" "Paste" render-page ;
-
-\ show-paste { { "n" v-number } } define-action
-
-: new-paste ( -- )
-    f "new-paste" "New paste" render-page ;
-
-\ new-paste { } define-action
-
-: submit-paste ( summary author channel contents -- )
-    <paste> pastebin get-global add-paste ;
-
-\ submit-paste {
-    { "summary" v-required }
-    { "author" v-required }
-    { "channel" "#concatenative" v-default }
-    { "contents" v-required }
-} define-action
-
-: paste-list ( -- )
-    [
-        [ show-paste ] "show-paste-quot" set
-        [ new-paste ] "new-paste-quot" set
-
-        pastebin get "paste-list" "Pastebin" render-page
-    ] with-scope ;
-
-\ paste-list { } define-action
-
-\ submit-paste [ paste-list ] define-redirect
-
-: annotate-paste ( paste# summary author contents -- )
-    <annotation> swap get-paste paste-annotations push ;
-
-\ annotate-paste {
-    { "n" v-required v-number }
-    { "summary" v-required }
-    { "author" v-required }
-    { "contents" v-required }
-} define-action
-
-\ annotate-paste [ "n" show-paste ] define-redirect
-
-"pastebin" "paste-list" "apps/furnace-pastebin" web-app

apps/furnace-pastebin/show-paste.fhtml

@@ -1,15 +0,0 @@
-<% USING: namespaces io furnace sequences ; %>
-
-<h1>Paste: <% "summary" get write %></h1>
-
-<table>
-<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
-<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
-<tr><th>Created:</th><td><% "date" get write %></td></tr>
-</table>
-
-<pre><% "contents" get write %></pre>
-
-<% "annotations" get [ "annotation" render-template ] each %>
-
-<% model get "annotate-paste" render-template %>

apps/hexdump/hexdump.factor

@@ -1,26 +0,0 @@
-USING: io kernel math namespaces prettyprint sequences strings ;
-IN: hexdump-internals
-	
-: header. ( len -- )
-    "Length: " write dup unparse write ", " write >hex write "h" write terpri ;
-
-: offset. ( lineno -- ) 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
-: h-pad. ( digit -- ) >hex 2 CHAR: 0 pad-left write ;
-: line. ( str n -- )
-    offset. [ [ h-pad. " " write ] each ] keep
-    16 over length - [ "   " write ] times
-    [ dup printable? [ drop CHAR: . ] unless ch>string write ] each
-    terpri ;
-
-IN: hexdump
-: hexdump ( str -- str )
-    #! Write hexdump to a string
-    [
-        dup length header.
-        16 group dup length [ line. ] 2each
-    ] string-out ;
-
-: hexdump. ( str -- )
-    #! Print hexdump
-    hexdump write ;
-

apps/hexdump/load.factor

@@ -1,3 +0,0 @@
-PROVIDE: apps/hexdump
-{ +files+ {  "hexdump.factor" } }
-{ +tests+ {  "test/hexdump.factor" } } ;

apps/hexdump/test/hexdump.factor

@@ -1,8 +0,0 @@
-IN: temporary
-USING: hexdump kernel sequences test ;
-
-[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
-[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a                   qrstuvwxyz\n" = ] unit-test
-
-[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f  !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
-

apps/lindenmayer/camera-slate.factor

@@ -1,74 +0,0 @@
-
-USING: kernel namespaces generic math gadgets vars slate turtle turtle-camera ;
-
-IN: camera-slate
-
-TUPLE: camera-slate ;
-
-C: camera-slate ( -- slate ) <slate> over set-delegate ;
-
-VAR: camera
-
-camera-slate H{
-  { T{ key-down f f "LEFT" }
-    [ slate-ns [ [ 5 turn-left ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f f "RIGHT" }
-    [ slate-ns [ [ 5 turn-right ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f f "UP" }
-    [ slate-ns [ [ 5 pitch-down ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f f "DOWN" }
-    [ slate-ns [ [ 5 pitch-up ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f f "LEFT" }
-    [ slate-ns [ [ 5 turn-left ] camera> with-turtle .slate ] bind ] }
-
-  { T{ key-down f f "a" }
-    [ slate-ns [ [ 1 step-turtle ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f f "z" }
-    [ slate-ns [ [ -1 step-turtle ] camera> with-turtle .slate ] bind ] }
-
-  { T{ key-down f f "q" }
-    [ slate-ns [ [ 5 roll-left ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f f "w" }
-    [ slate-ns [ [ 5 roll-right ] camera> with-turtle .slate ] bind ] }
-
-  { T{ key-down f { A+ } "LEFT" }
-    [ slate-ns [ [ 1 strafe-left ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f { A+ } "RIGHT" }
-    [ slate-ns [ [ 1 strafe-right ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f { A+ } "UP" }
-    [ slate-ns [ [ 1 strafe-up ] camera> with-turtle .slate ] bind ] }
-  { T{ key-down f { A+ } "DOWN" }
-    [ slate-ns [ [ 1 strafe-down ] camera> with-turtle .slate ] bind ] }
-
-  { T{ key-down f f "1" }
-    [ slate-ns
-      [
-        [ position> norm reset-turtle 90 turn-left step-turtle 180 turn-left ]
-        camera> with-turtle .slate
-      ] bind
-    ] }
-  { T{ key-down f f "2" }
-    [ slate-ns
-      [
-        [ position> norm reset-turtle 90 pitch-up step-turtle 180 pitch-down ]
-        camera> with-turtle .slate
-      ] bind
-    ] }
-  { T{ key-down f f "3" }
-    [ slate-ns
-      [
-        [ position> norm reset-turtle step-turtle 180 turn-left ]
-        camera> with-turtle .slate
-      ] bind
-    ] }
-
-{ T{ key-down f f "4" }
-    [ slate-ns
-      [
-        [ position> norm
-          reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
-        camera> with-turtle .slate
-      ] bind
-    ] }
-
-} set-gestures

apps/lindenmayer/camera.factor

@@ -1,17 +0,0 @@
-USING: kernel math sequences opengl turtle ;
-IN: turtle-camera
-
-: camera-eye ( -- array ) position> ;
-
-: camera-focus ( -- array )
-push-turtle
-1 step-turtle position>
-pop-turtle ;
-
-: camera-up ( -- array )
-push-turtle
-90 pitch-up position> 1 step-turtle position> swap v-
-pop-turtle ;
-
-: do-look-at ( -- )
-camera-eye first3 camera-focus first3 camera-up first3 gluLookAt ;

apps/lindenmayer/lindenmayer.factor

@@ -1,582 +0,0 @@
-! Eduardo Cavazos - wayo.cavazos@gmail.com
-
-REQUIRES: libs/math
-          libs/vars
-          libs/slate
-          apps/lindenmayer/opengl
-          apps/lindenmayer/turtle
-          apps/lindenmayer/camera
-          apps/lindenmayer/camera-slate ;
-
-USING: kernel alien namespaces arrays vectors math opengl sequences threads
-       hashtables strings gadgets
-       math-contrib vars slate turtle turtle-camera camera-slate
-       opengl-contrib ;
-
-IN: lindenmayer 
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: record-vertex ( -- ) position> gl-vertex ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: polygon-vertex
-
-: draw-forward ( length -- )
-GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ;
-
-: move-forward ( length -- ) step-turtle polygon-vertex ;
-
-: sneak-forward ( length -- ) step-turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! (v0 - v1) x (v1 - v2)
-
-: polygon-normal ( {_v0_v1_v2_} -- normal ) first3 dupd v- -rot v- swap cross ;
-
-: (polygon) ( vertices -- )
-GL_POLYGON glBegin dup polygon-normal gl-normal [ gl-vertex ] each glEnd ;
-
-: polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Maybe use an array instead of a vector
-
-VAR: vertices
-
-: start-polygon ( -- ) 0 <vector> >vertices ;
-
-: finish-polygon ( -- ) vertices> polygon ;
-
-: polygon-vertex ( -- ) position> vertices> push ;
-
-: reset-vertices start-polygon ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Lindenmayer string rewriting
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Maybe use an array instead of a quot in the work of segment
-
-VAR: rules
-
-: segment ( str -- seq )
-{ { [ dup "" = ] [ drop [ ] ] }
-  { [ dup length 1 = ] [ unit ] }
-  { [ 1 over nth CHAR: ( = ]
-    [ CHAR: ) over index 1 +		! str i
-      2dup head				! str i head
-      -rot tail				! head tail
-      segment swap add* ] }
-  { [ t ] [ dup 1 head swap 1 tail segment swap add* ] } }
-cond ;
-
-: lookup ( str -- str ) dup 1 head rules get hash dup [ nip ] [ drop ] if ;
-
-: rewrite ( str -- str ) segment [ lookup ] map concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Lindenmayer string interpretation
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: command-table
-
-: segment-command ( seg -- command ) 1 head ;
-
-: segment-parameter ( seg -- parameter )
-dup length 1 - 2 swap rot subseq string>number ;
-
-: segment-parts ( seg -- param command )
-dup segment-parameter swap segment-command ;
-
-: exec-command ( str -- ) command-table get hash dup [ call ] [ drop ] if ;
-
-: exec-command-with-param ( param command -- )
-command-table get hash dup [ peek unit call ] [ 2drop ] if ;
-
-: (interpret) ( seg -- )
-dup length 1 =
-[ exec-command ] [ segment-parts exec-command-with-param ] if ;
-
-: interpret ( str -- ) segment [ (interpret) ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Lparser dialect
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: angle
-VAR: len
-VAR: thickness
-VAR: color-index
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: set-thickness
-DEFER: set-color-index
-
-TUPLE: state position orientation angle len thickness color-index ;
-
-VAR: states
-
-: reset-state-stack ( -- ) V{ } clone >states ;
-
-: save-state ( -- )
-position> orientation> angle> len> thickness> color-index> <state>
-states> push ;
-
-: restore-state ( -- )
-states> pop
-dup state-position    >position
-dup state-orientation >orientation
-dup state-len         >len
-dup state-angle       >angle
-dup state-color-index set-color-index
-dup state-thickness   set-thickness
-drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: scale-len ( m -- ) len> * >len ;
-
-: scale-angle ( m -- ) angle> * >angle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: color-table
-
-: init-color-table ( -- )
-{ { 0    0    0 }    ! black
-  { 0.5  0.5  0.5 }  ! grey
-  { 1    0    0 }    ! red
-  { 1    1    0 }    ! yellow
-  { 0    1    0 }    ! green
-  { 0.25 0.88 0.82 } ! turquoise
-  { 0    0    1 }    ! blue
-  { 0.63 0.13 0.94 } ! purple
-  { 0.00 0.50 0.00 } ! dark green
-  { 0.00 0.82 0.82 } ! dark turquoise
-  { 0.00 0.00 0.50 } ! dark blue
-  { 0.58 0.00 0.82 } ! dark purple
-  { 0.50 0.00 0.00 } ! dark red
-  { 0.25 0.25 0.25 } ! dark grey
-  { 0.75 0.75 0.75 } ! medium grey
-  { 1    1    1 }    ! white
-} [ 1 set-color-alpha ] map color-table set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: material-color ( color -- )
-GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material-fv ;
-
-: set-color-index ( i -- )
-dup >color-index color-table> nth dup gl-color material-color ;
-
-: inc-color-index ( -- ) color-index> 1 + set-color-index ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-thickness ( i -- ) dup >thickness glLineWidth ;
-
-: scale-thickness ( m -- ) thickness> * 0.5 max set-thickness ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: default-values
-VAR: model-values
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: lparser-dialect ( -- )
-
-[ 1 >len   45 >angle   1 >thickness   2 >color-index ] >default-values
-
-H{ { "+" [ angle get     turn-left ] }
-   { "-" [ angle get     turn-right ] }
-   { "&" [ angle get     pitch-down ] }
-   { "^" [ angle get     pitch-up ] }
-   { "<" [ angle get     roll-left ] }
-   { ">" [ angle get     roll-right ] }
-
-   { "|" [ 180.0         rotate-y ] }
-   { "%" [ 180.0         rotate-z ] }
-   { "$" [ roll-until-horizontal ]  }
-
-   { "F" [ len get     draw-forward ] }
-   { "Z" [ len get 2 / draw-forward ] }
-   { "f" [ len get     move-forward ] }
-   { "z" [ len get 2 / move-forward ] }
-   { "g" [ len get     sneak-forward ] }
-   { "." [ polygon-vertex ] }
-
-   { "[" [ save-state ] }
-   { "]" [ restore-state ] }
-   { "{" [ start-polygon ] }
-   { "}" [ finish-polygon ] }
-
-   { "/" [ 1.1 scale-len ] } ! double quote command in lparser
-   { "'" [ 0.9 scale-len ] }
-   { ";" [ 1.1 scale-angle ] }
-   { ":" [ 0.9 scale-angle ] }
-   { "?" [ 1.4 scale-thickness ] }
-   { "!" [ 0.7 scale-thickness ] }
-
-   { "c" [ color-index> 1 + color-table get length mod set-color-index ] }
-
-} command-table set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: axiom
-VAR: result
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate ( -- ) result> rewrite >result ;
-
-: iterations ( n -- ) [ iterate ] times ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: model
-
-: init-model ( -- ) 1 glGenLists >model ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: display ( -- )
-
-black gl-clear-color
-
-GL_FLAT glShadeModel
-
-GL_PROJECTION glMatrixMode
-glLoadIdentity
--1 1 -1 1 1.5 200 glFrustum
-
-GL_MODELVIEW glMatrixMode
-
-glLoadIdentity
-
-[ do-look-at ] camera> with-turtle
-
-GL_COLOR_BUFFER_BIT glClear
-
-GL_FRONT_AND_BACK GL_LINE glPolygonMode
-
-white gl-color
-GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
-
-color-index> set-color-index
-
-model> glCallList ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-turtle ( -- ) <turtle> >turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-camera ( -- ) <turtle> >camera ;
-
-: reset-camera ( -- ) [
-reset-turtle
-45 turn-left
-45 pitch-up
-5 step-turtle
-180 turn-left
-] camera> with-turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( -- )
-<camera-slate> >slate
-namespace slate> set-slate-ns
-slate> "L-system" open-titled-window
-[ display ] >action ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
-init-turtle
-init-turtle-stack
-init-camera reset-camera
-init-model
-
-2 >color-index
-init-color-table
-
-init-slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: result>model ( -- )
-[ model> GL_COMPILE glNewList result> interpret glEndList ] >action .slate ;
-
-: build-model ( -- )
-reset-state-stack
-reset-vertices
-reset-turtle
-default-values> call
-model-values> call
-result>model
-3000 sleep
-[ display ] >action .slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Examples
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: koch ( -- ) lparser-dialect   [ 90 >angle ] >model-values
-
-H{ { "K" "[[a|b] '(0.41)f'(2.439) |<(60) [a|b]]" }
-   { "k" "[ c'(0.5) K]" }
-   { "a" "[d <(120) d <(120) d ]" }
-   { "b" "e" }
-   { "e" "[^ '(.2887)f'(3.4758) &(180)      +z{.-(120)f-(120)f}]" }
-   { "d" "[^ '(.2887)f'(3.4758) &(109.5111) +zk{.-(120)f-(120)f}]" }
-} >rules
-
-"K" >result ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: spiral-0 ( -- ) lparser-dialect   [ 10 >angle 5 >thickness ] >model-values
-
-"[P]|[P]" >result
-
-H{ { "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" }
-   { "A" "F+;'A" }
-   { "B" "F!+F+;'B" }
-   { "C" "F!^+F^+;'C" }
-   { "D" "F!>^+F>^+;'D" }
-} >rules ;
-
-: spiral-0-scene ( -- )
-spiral-0
-22 iterations
-build-model
-[ reset-turtle 90 turn-left 16 step-turtle 180 turn-left ]
-camera> with-turtle .slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tree-5 ( -- ) lparser-dialect   [ 5 >angle   1 >thickness ] >model-values
-
-"c(4)FFS" >result
-
-H{ { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
-   { "R" "[Ba]" }
-   { "a" "$tF[Cx]Fb" }
-   { "b" "$tF[Dy]Fa" }
-   { "B" "&B" }
-   { "C" "+C" }
-   { "D" "-D" }
-
-   { "x" "a" }
-   { "y" "b" }
-
-   { "F" "'(1.25)F'(.8)" }
-} >rules ;
-
-: tree-5-scene ( -- )
-tree-5
-9 iterations
-build-model
-[ reset-turtle 90 pitch-down -70 step-turtle 50 strafe-up ] camera> with-turtle
-.slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-1 ( -- ) lparser-dialect   [ 45 >angle   5 >thickness ] >model-values
-
-H{ { "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
-   { "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
-   { "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
-
-   { "L" "~c(8){+(30)f-(120)f-(120)f}" }
-} >rules
-
-"c(12)FFAL" >result ;
-
-: abop-1-scene ( -- )
-abop-1
-8 iterations
-build-model
-[ reset-turtle
-  90 pitch-up 7 step-turtle 90 pitch-down 4 step-turtle 90 pitch-down ]
-camera> with-turtle .slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-2 ( -- ) lparser-dialect   [ 30 >angle   5 >thickness ] >model-values
-
-H{ { "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" }
-   { "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" }
-   { "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" }
-
-   { "L" "~c(8){+(45)f(.1)-(45)f(.1)-(45)f(.1)+(45)|+(45)f(.1)-(45)f(.1)-(45)f(.1)}" }
-
-} >rules
-
-"c(12)FAL" >result ;
-
-: abop-2-scene ( -- )
-abop-2
-7 iterations
-build-model
-[ reset-turtle { 0 4 4 } >position 90 pitch-down ]
-camera> with-turtle .slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-3 ( -- ) lparser-dialect   [ 30 >angle   5 >thickness ] >model-values
-
-H{ { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
-   { "B" "[&t(.4)F$A]" }
-   { "F" "'(1.25)F'(.8)" }
-} >rules
-
-"c(12)FA" >result ;
-
-: abop-3-scene ( -- )
-abop-3 11 iterations build-model
-[ reset-turtle { 0 47 29 } >position 90 pitch-down ] camera> with-turtle
-.slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-4 ( -- ) lparser-dialect   [ 18 >angle   5 >thickness ] >model-values
-
-H{ { "N" "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK" }
-   { "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
-   { "l" "g(.2)l" }
-   { "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
-   { "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
-   { "f" "_" }
-
-   { "A" "B" }
-   { "B" "C" }
-   { "C" "D" }
-   { "D" "E" }
-   { "E" "G" }
-   { "G" "H" }
-   { "H" "N" }
-
-   { "I" "FoO" }
-   { "O" "FoP" }
-   { "P" "FoQ" }
-   { "Q" "FoR" }
-   { "R" "FoS" }
-   { "S" "FoT" }
-   { "T" "FoU" }
-   { "U" "FoV" }
-   { "V" "FoW" }
-   { "W" "FoX" }
-   { "X" "_" }
-
-   { "o" "$t(-0.03)" }
-   { "r" "~(30)" }
-} >rules
-
-"c(12)&(20)N" >result ;
-
-: abop-4-scene ( -- )
-abop-4 21 iterations build-model
-[ reset-turtle
-  { 53 25 36 } >position
-  { { 0.57 -0.14 -0.80 } { -0.81 -0.18 -0.54 } { -0.07 0.97 -0.22 } }
-  >orientation
-] camera> with-turtle .slate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-5 ( -- ) lparser-dialect   [ 5 >angle   5 >thickness ] >model-values
-
-H{ { "a" "F[+(45)l][-(45)l]^;ca" }
-
-   { "l" "j" }
-   { "j" "h" }
-   { "h" "s" }
-   { "s" "d" }
-   { "d" "x" }
-   { "x" "a" }
-
-   { "F" "'(1.17)F'(.855)" }
-} >rules
-
-"&(90)+(90)a" >result ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-6 ( -- ) lparser-dialect   [ 5 >angle   5 >thickness ] >model-values
-
-"&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x" >result
-
-H{ { "a" "F[cdx][cex]F!(.9)a" }
-   { "x" "a" }
-
-   { "d" "+d" }
-   { "e" "-e" }
-
-   { "F" "'(1.25)F'(.8)" }
-} >rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: airhorse ( -- ) lparser-dialect [ 10 >angle 5 >thickness ] >model-values
-
-"C" >result
-
-H{ { "C" "LBW" }
-
-   { "B" "[[''aH]|[g]]" }
-   { "a" "Fs+;'a" }
-   { "g" "Ft+;'g" }
-   { "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
-   { "t" "[c!!!!&[FF]^^FF]" }
-
-   { "L" "O" }
-   { "O" "P" }
-   { "P" "Q" }
-   { "Q" "R" }
-   { "R" "U" }
-   { "U" "X" }
-   { "X" "Y" }
-   { "Y" "V" }
-   { "V" "[cc!!!&(90)[Zp]|[Zp]]" }
-   { "p" "h>(120)h>(120)h" }
-   { "h" "[+(40)!F'''p]" }
-
-   { "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
-   { "d" "Z!&Z!&:'d" }
-   { "e" "Z!^Z!^:'e" }
-   { "i" "-:/i" }
-
-   { "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
-   { "b" "Fl!+Fl+;'b" }
-   { "l" "[-cc{--z++z++z--|--z++z++z}]" }
-} >rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! These should be moved into a separate file. They are used to pretty
-! print matricies and vectors.
-
-USING: styles prettyprint io ;
-
-: decimal-places ( n d -- n )
-10 swap ^ tuck * >fixnum swap /f ;
-
-! : .mat ( matrix -- ) [ [ 2 decimal-places ] map ] map . ;
-
-: .mat ( matrix -- )
-H{ { table-gap 4 } { table-border 4 } }
-[ 2 decimal-places pprint ]
-tabular-output ;
-
-: .vec ( vector -- ) [ 2 decimal-places ] map . ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

apps/lindenmayer/load.factor

@@ -1,2 +0,0 @@
-PROVIDE: apps/lindenmayer
-{ +files+ { "lindenmayer.factor" } } ;

apps/lindenmayer/opengl.factor

@@ -1,38 +0,0 @@
-REQUIRES: libs/alien ;
-USING: kernel sequences opengl alien-contrib ;
-IN: opengl-contrib
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-clear-color ( 4seq -- ) first4 glClearColor ;
-
-: gl-vertex-3f ( 3seq -- ) first3 glVertex3f ;
-
-: gl-vertex ( 3seq -- ) gl-vertex-3f ;
-
-: gl-normal-3f ( vec -- ) first3 glNormal3f ;
-
-: gl-normal ( vec -- ) gl-normal-3f ;
-
-: gl-material-fv ( face pname params -- ) >float-array glMaterialfv ;
-
-: gl-color ( vec -- ) first4 glColor4f ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Misc stuff that should probably go in a separate file
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: black ( -- color ) { 0 0 0 1 } ;
-
-: white ( -- color ) { 1 1 1 1 } ;
-
-: red ( -- color ) { 1 0 0 1 } ;
-
-: green ( -- color ) { 0 1 0 1 } ;
-
-: blue ( -- color ) { 0 0 1 1 } ;
-
-: yellow ( -- color ) { 1 1 0 1 } ;
-
-: set-color-alpha ( color alpha -- color ) swap 3 head swap add ;
-

apps/lindenmayer/turtle.factor

@@ -1,135 +0,0 @@
-REQUIRES: libs/math libs/vars ;
-USING: kernel math namespaces sequences arrays math-contrib vars ;
-IN: turtle
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: turtle position orientation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: turtle
-
-: position> ( -- position ) turtle> turtle-position ;
-
-: >position ( position -- ) turtle> set-turtle-position ;
-
-: orientation> ( -- orientation ) turtle> turtle-orientation ;
-
-: >orientation ( orientation -- ) turtle> set-turtle-orientation ;
-
-: with-turtle ( quot turtle -- ) [ >turtle call ] with-scope ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reset-turtle ( -- ) { 0 0 0 } >position 3 identity-matrix >orientation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-C: turtle ( -- ) [ reset-turtle ] over with-turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-matrix >r { } make r> group ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! These rotation matrices are from
-! `Computer Graphics: Principles and Practice'
-
-: Rz ( angle -- Rx ) deg>rad
-[ dup cos ,	dup sin neg ,	0 ,
-  dup sin ,	dup cos ,	0 ,
-  0 ,		0 ,		1 , ] 3 make-matrix nip ;
-
-: Ry ( angle -- Ry ) deg>rad
-[ dup cos ,	0 ,		dup sin ,
-  0 ,		1 ,		0 ,
-  dup sin neg ,	0 ,		dup cos , ] 3 make-matrix nip ;
-
-: Rx ( angle -- Rz ) deg>rad
-[ 1 ,		0 ,		0 ,
-  0 ,		dup cos ,	dup sin neg ,
-  0 ,		dup sin ,	dup cos , ] 3 make-matrix nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-rotation ( rotation -- ) orientation> swap m. >orientation ;
-
-: rotate-x ( angle -- ) Rx apply-rotation ;
-: rotate-y ( angle -- ) Ry apply-rotation ;
-: rotate-z ( angle -- ) Rz apply-rotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pitch-up   ( angle -- ) neg rotate-x ;
-: pitch-down ( angle -- )     rotate-x ;
-
-: turn-left ( angle -- )      rotate-y ;
-: turn-right ( angle -- ) neg rotate-y ;
-
-: roll-left  ( angle -- ) neg rotate-z ;
-: roll-right ( angle -- )     rotate-z ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-vector ( length -- array ) { 0 0 1 } n*v ;
-
-: step-turtle ( length -- )
-step-vector orientation> swap m.v position> v+ >position ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: strafe-up ( length -- )
-90 pitch-up
-step-turtle
-90 pitch-down ;
-
-: strafe-down ( length -- )
-90 pitch-down
-step-turtle
-90 pitch-up ;
-
-: strafe-left ( length -- )
-90 turn-left
-step-turtle
-90 turn-right ;
-
-: strafe-right ( length -- )
-90 turn-right
-step-turtle
-90 turn-left ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: turtle-stack
-
-: init-turtle-stack ( -- ) V{ } clone >turtle-stack ;
-
-: push-turtle ( -- ) turtle> clone turtle-stack> push ;
-
-! : pop-turtle ( -- ) turtle-stack> pop >turtle ;
-
-: pop-turtle ( -- )
-turtle-stack> pop dup
-turtle-position >position
-turtle-orientation >orientation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! roll-until-horizontal
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: V ( -- V ) { 0 1 0 } ;
-
-: X ( -- 3array ) orientation> [ first  ] map ;
-: Y ( -- 3array ) orientation> [ second ] map ;
-: Z ( -- 3array ) orientation> [ third  ] map ;
-
-: set-X ( seq -- ) orientation> [ 0 swap set-nth ] 2each ;
-: set-Y ( seq -- ) orientation> [ 1 swap set-nth ] 2each ;
-: set-Z ( seq -- ) orientation> [ 2 swap set-nth ] 2each ;
-
-: roll-until-horizontal ( -- )
-V Z cross normalize set-X
-Z X cross normalize set-Y ;
-

apps/lisppaste.factor

@@ -1,15 +0,0 @@
-IN: lisppaste
-REQUIRES: libs/xml-rpc ;
-USING: arrays kernel xml-rpc ;
-
-: url "http://www.common-lisp.net:8185/RPC2" ;
-
-: channels ( -- seq )
-    { } "listchannels" url invoke-method ;
-
-: lisppaste ( seq -- response )
-    ! seq is { channel user title contents }
-    ! or { channel user title contents annotation-number }
-    "newpaste" url invoke-method ;
-
-PROVIDE: apps/lisppaste ;

apps/mandel/load.factor

@@ -1,8 +0,0 @@
-PROVIDE: apps/mandel
-{ +files+ { "mandel.factor" } }
-{ +tests+ { "tests.factor" } } ;
-
-USE: mandel
-USE: test
-
-MAIN: apps/mandel [ "mandel.pnm" run>file ] time ;

apps/mandel/mandel.factor

@@ -1,92 +0,0 @@
-! Run this file to write a Mandelbrot fractal to "mandel.ppm".
-
-IN: mandel
-USING: arrays compiler io kernel math namespaces sequences
-strings test ;
-
-: max-color 360 ; inline
-: zoom-fact 0.8 ; inline
-: width 640 ; inline
-: height 480 ; inline
-: nb-iter 40 ; inline
-: center -0.65 ; inline
-
-: f_ >r swap rot >r 2dup r> 6 * r> - ;
-: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
-: q ( v s f -- q ) * neg 1 + * ;
-: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
-
-: mod-cond ( p vector -- )
-    #! Call p mod q'th entry of the vector of quotations, where
-    #! q is the length of the vector. The value q remains on the
-    #! stack.
-    [ dupd length mod ] keep nth call ;
-
-: hsv>rgb ( h s v -- r g b )
-    pick 6 * >fixnum {
-        [ f_ t_ p swap     ] ! v p t
-        [ f_ q  p -rot     ] ! q v p
-        [ f_ t_ p swapd    ] ! p v t
-        [ f_ q  p rot      ] ! p q v
-        [ f_ t_ p swap rot ] ! t p v
-        [ f_ q  p          ] ! v p q
-    } mod-cond ;
-
-: scale 255 * >fixnum ; inline
-
-: scale-rgb ( r g b -- n )
-    rot scale rot scale rot scale 3array ;
-
-: sat 0.85 ; inline
-: val 0.85 ; inline
-
-: <color-map> ( nb-cols -- map )
-    dup [
-        360 * swap 1+ / 360 / sat val
-        hsv>rgb scale-rgb
-    ] map-with ;
-
-: iter ( c z nb-iter -- x )
-    over absq 4.0 >= over zero? or
-    [ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline
-
-SYMBOL: cols
-
-: x-inc width 200000 zoom-fact * / ; inline
-: y-inc height 150000 zoom-fact * / ; inline
-
-: c ( i j -- c )
-    >r
-    x-inc * center real x-inc width 2 / * - + >float
-    r>
-    y-inc * center imaginary y-inc height 2 / * - + >float
-    rect> ; inline
-
-: render ( -- )
-    height [
-        width [
-            2dup swap c 0 nb-iter iter dup zero? [
-                drop "\0\0\0"
-            ] [
-                cols get [ length mod ] keep nth
-            ] if %
-        ] repeat
-    ] repeat ;
-
-: ppm-header ( w h -- )
-    "P6\n" % swap # " " % # "\n255\n" % ;
-
-: sbuf-size width height * 3 * 100 + ;
-
-: run ( -- string )
-    [
-        sbuf-size <sbuf> building set
-        width height ppm-header
-        nb-iter max-color min <color-map> cols set
-        render
-        building get >string
-    ] with-scope ;
-
-: run>file ( file -- )
-    "Generating " write dup write "..." print
-    <file-writer> [ run write ] with-stream ;

apps/mandel/tests.factor

@@ -1,25 +0,0 @@
-IN: mandel
-USE: test
-
-[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
-
-[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
-[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
-
-[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
-[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
-
-[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
-[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
-
-[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
-[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
-
-[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
-[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
-
-[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
-[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
-
-[ 1 0 0 ] [ 1 1 1 hsv>rgb ] unit-test
-[ 1/6 1/9 1/9 ] [ 1 1/3 1/6 hsv>rgb ] unit-test

apps/random-tester/load.factor

@@ -1,9 +0,0 @@
-REQUIRES: libs/lazy-lists libs/shuffle ;
-PROVIDE: apps/random-tester
-{ +files+ {
-    "utils.factor"
-    "random.factor"
-    "random-tester.factor"
-    "random-tester2.factor"
-    "type.factor"
-} } ;

apps/random-tester/random-tester.factor

@@ -1,301 +0,0 @@
-USING: kernel math math-internals memory sequences namespaces errors
-hashtables words  arrays parser compiler syntax io
-tools prettyprint optimizer inference ;
-IN: random-tester
-
-! n-foo>bar -- list of words of type 'foo' that take n parameters
-!              and output a 'bar'
-
-
-! Math vocabulary words
-: 1-x>y
-    {
-        1+ 1- >bignum >digit >fixnum abs absq arg 
-        bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
-        cosh cot coth denominator double>bits exp float>bits floor imaginary
-        log neg numerator real sec ! next-power-of-2
-        sech sgn sin sinh sq sqrt tan tanh truncate 
-    } ;
-
-: 1-x>y-throws
-    {
-        recip log2
-        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
-    } ;
-
-: 2-x>y ( -- seq ) { * + - /f max min polar> bitand bitor bitxor align } ;
-: 2-x>y-throws ( -- seq ) { / /i mod rem } ;
-
-: 1-integer>x
-    {
-        1+ 1- >bignum >digit >fixnum abs absq arg 
-        bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
-        cosh cot coth denominator exp floor imaginary
-        log neg next-power-of-2 numerator real sec
-        sech sgn sin sinh sq sqrt tan tanh truncate 
-    } ;
-
-: 1-ratio>x
-    {
-        1+ 1- >bignum >digit >fixnum abs absq arg ceiling
-        cis conjugate cos cosec cosech
-        cosh cot coth exp floor imaginary
-        log neg next-power-of-2 real sec
-        sech sgn sin sinh sq sqrt tan tanh truncate 
-    } ;
-
-: 1-float>x ( -- seq )
-    {
-        1+ 1- >bignum >digit >fixnum abs absq arg 
-        ceiling cis conjugate cos cosec cosech
-        cosh cot coth double>bits exp float>bits floor imaginary
-        log neg real sec ! next-power-of-2
-        sech sgn sin sinh sq sqrt tan tanh truncate
-    } ;
-
-: 1-complex>x
-    {
-        1+ 1- abs absq arg conjugate cos cosec cosech
-        cosh cot coth exp imaginary log neg real
-        sec sech sin sinh sq sqrt tan tanh 
-    } ;
-
-: 1-integer>x-throws
-    {
-        recip log2
-        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
-    } ;
-
-: 1-ratio>x-throws
-    {
-        recip
-        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
-    } ;
-
-: 1-integer>integer
-    {
-        1+ 1- >bignum >digit >fixnum abs absq bitnot ceiling conjugate 
-        denominator floor imaginary
-        neg next-power-of-2 numerator real sgn sq truncate 
-    } ;
-
-: 1-ratio>ratio
-    { 1+ 1- >digit abs absq conjugate neg real sq } ;
-
-: 1-float>float
-    {
-        1+ 1- >digit abs absq arg ceiling
-        conjugate exp floor neg real sq truncate
-    } ;
-
-: 1-complex>complex
-    {
-        1+ 1- abs absq arg conjugate cosec cosech cosh cot coth exp log
-        neg sech sin sinh sq sqrt tanh 
-    } ;
-
-: 2-integer>x { * + - /f max min polar> bitand bitor bitxor align } ;
-: 2-ratio>x { * + - /f max min polar> } ;
-: 2-float>x { float+ float- float* float/f + - * /f max min polar> } ;
-: 2-complex>x { * + - /f } ;
-
-: 2-integer>integer { * + - max min bitand bitor bitxor align } ;
-: 2-ratio>ratio { * + - max min } ;
-: 2-float>float { float* float+ float- float/f max min /f + - } ;
-: 2-complex>complex { * + - /f } ;
-
-
-SYMBOL: last-quot
-SYMBOL: first-arg
-SYMBOL: second-arg
-: 0-runtime-check ( quot -- )
-    #! Checks the runtime only, not the compiler
-    #! Evaluates the quotation twice and makes sure the results agree
-    [ last-quot set ] keep
-    [ call ] keep
-    call
-    ! 2dup swap unparse write " " write unparse print flush
-    = [ last-quot get . "problem in runtime" throw ] unless ;
-
-: 1-runtime-check ( quot -- )
-    #! Checks the runtime only, not the compiler
-    #! Evaluates the quotation twice and makes sure the results agree
-    #! For quotations that are given one argument
-    [ last-quot set first-arg set ] 2keep
-    [ call ] 2keep
-    call
-    2dup swap unparse write " " write unparse print flush
-    = [ "problem in runtime" throw ] unless ;
-
-: 1-interpreted-vs-compiled-check ( x quot -- ) 
-    #! Checks the runtime output vs the compiler output
-    #! quot: ( x -- y )
-    2dup swap unparse write " " write . flush
-    [ last-quot set first-arg set ] 2keep
-    [ call ] 2keep compile-1
-    2dup swap unparse write " " write unparse print flush
-    = [ "problem in math1" throw ] unless ;
-
-: 2-interpreted-vs-compiled-check ( x y quot -- )
-    #! Checks the runtime output vs the compiler output
-    #! quot: ( x y -- z )
-    .s flush
-    [ last-quot set first-arg set second-arg set ] 3keep
-    [ call ] 3keep compile-1
-    2dup swap unparse write " " write unparse print flush
-    = [ "problem in math2" throw ] unless ;
-
-: 0-interpreted-vs-compiled-check-catch ( quot -- )
-    #! Check the runtime output vs the compiler output for words that throw
-    #!
-    dup .
-    [ last-quot set ] keep
-    [ catch [ "caught: " write dup print-error ] when* ] keep 
-    [ compile-1 ] catch [ nip "caught: " write dup print-error ] when*
-    = [ "problem in math3" throw ] unless ;
-
-: 1-interpreted-vs-compiled-check-catch ( quot -- )
-    #! Check the runtime output vs the compiler output for words that throw
-    2dup swap unparse write " " write .
-    ! "." write
-    [ last-quot set first-arg set ] 2keep
-    [ catch [ nip "caught: " write dup print-error ] when* ] 2keep 
-    [ compile-1 ] catch [ 2nip "caught: " write dup print-error ] when*
-    = [ "problem in math4" throw ] unless ;
-
-: 2-interpreted-vs-compiled-check-catch ( quot -- )
-    #! Check the runtime output vs the compiler output for words that throw
-    ! 3dup rot unparse write " " write swap unparse write " " write .
-    "." write
-    [ last-quot set first-arg set second-arg set ] 3keep
-    [ catch [ 2nip "caught: " write dup print-error ] when* ] 3keep
-    [ compile-1 ] catch [ 2nip nip "caught: " write dup print-error ] when*
-    = [ "problem in math5" throw ] unless ;
-
-
-! RANDOM QUOTATIONS TO TEST
-: random-1-integer>x-quot ( -- quot ) 1-integer>x pick-one unit ;
-: random-1-ratio>x-quot ( -- quot ) 1-ratio>x pick-one unit ;
-: random-1-float>x-quot ( -- quot ) 1-float>x pick-one unit ;
-: random-1-complex>x-quot ( -- quot ) 1-complex>x pick-one unit ;
-
-: test-1-integer>x ( -- )
-    random-integer random-1-integer>x-quot 1-interpreted-vs-compiled-check ;
-: test-1-ratio>x ( -- )
-    random-ratio random-1-ratio>x-quot 1-interpreted-vs-compiled-check ;
-: test-1-float>x ( -- )
-    random-float random-1-float>x-quot 1-interpreted-vs-compiled-check ;
-: test-1-complex>x ( -- )
-    random-complex random-1-complex>x-quot 1-interpreted-vs-compiled-check ;
-
-
-: random-1-float>float-quot ( -- obj ) 1-float>float pick-one unit ;
-: random-2-float>float-quot ( -- obj ) 2-float>float pick-one unit ;
-: nrandom-2-float>float-quot ( -- obj )
-    [
-        5
-        [
-            {
-                [ 2-float>float pick-one , random-float , ]
-                [ 1-float>float pick-one ,  ]
-            } do-one
-        ] times 
-        2-float>float pick-one ,
-    ] [ ] make ;
-
-: test-1-float>float ( -- )
-    random-float random-1-float>float-quot 1-interpreted-vs-compiled-check ;
-: test-2-float>float ( -- )
-    random-float random-float random-2-float>float-quot
-    2-interpreted-vs-compiled-check ;
-
-: test-n-2-float>float ( -- )
-    random-float random-float nrandom-2-float>float-quot
-    2-interpreted-vs-compiled-check ;
-
-: test-1-integer>x-runtime ( -- )
-    random-integer random-1-integer>x-quot 1-runtime-check ;
-
-: random-1-integer>x-throws-quot ( -- obj ) 1-integer>x-throws pick-one unit ;
-: random-1-ratio>x-throws-quot ( -- obj ) 1-ratio>x-throws pick-one unit ;
-: test-1-integer>x-throws ( -- obj )
-    random-integer random-1-integer>x-throws-quot
-    1-interpreted-vs-compiled-check-catch ;
-: test-1-ratio>x-throws ( -- obj )
-    random-ratio random-1-ratio>x-throws-quot
-    1-interpreted-vs-compiled-check-catch ;
-
-
-
-: test-2-integer>x-throws ( -- )
-    [
-        random-integer , random-integer ,
-        2-x>y-throws pick-one ,
-    ] [ ] make 2-interpreted-vs-compiled-check-catch ;
-
-! : test-^-ratio ( -- )
-    ! [
-        ! random-ratio , random-ratio , \ ^ ,
-    ! ] [ ] make interp-compile-check-catch ;
-
-: test-0-float?-when
-    [
-        random-number , \ dup , \ float? , 1-float>x pick-one unit , \ when ,
-    ] [ ] make 0-runtime-check ;
-
-: test-1-integer?-when
-    random-integer [
-        \ dup , \ integer? , 1-integer>x pick-one unit , \ when ,
-    ] [ ] make 1-interpreted-vs-compiled-check ;
-
-: test-1-ratio?-when
-    random-ratio [
-        \ dup , \ ratio? , 1-ratio>x pick-one unit , \ when ,
-    ] [ ] make 1-interpreted-vs-compiled-check ;
-
-: test-1-float?-when
-    random-float [
-        \ dup , \ float? , 1-float>x pick-one unit , \ when ,
-    ] [ ] make 1-interpreted-vs-compiled-check ;
-
-: test-1-complex?-when
-    random-complex [
-        \ dup , \ complex? , 1-complex>x pick-one unit , \ when ,
-    ] [ ] make 1-interpreted-vs-compiled-check ;
-
-
-: many-word-test ( -- )
-    #! defines words a1000 down to a0, which does a trivial addition
-    "random-tester-scratchpad" vocabularies get remove-hash
-    "random-tester-scratchpad" [ ensure-vocab ] keep use+
-    "a0" "random-tester-scratchpad" create [ 1 1 + ] define-compound
-    100 [
-        [ 1+ "a" swap unparse append "random-tester-scratchpad" create ] keep
-        "a" swap unparse append [ parse ] catch [ 0 :res ] when define-compound
-    ] each ;
-
-: compile-loop ( -- )
-    10 [ many-word-test "a100" parse first compile ] times ;
-
-: random-test
-    "----" print
-    {
-        test-1-integer>x
-        test-1-ratio>x
-        test-1-float>x
-        test-1-complex>x
-        test-1-integer>x-throws
-        test-1-ratio>x-throws
-        test-1-float>float
-        test-2-float>float
-        ! test-n-2-float>float
-        test-1-integer>x-runtime
-        ! test-0-float?-when
-        test-1-integer?-when
-        test-1-ratio?-when
-        test-1-float?-when
-        test-1-complex?-when
-        ! full-gc
-        ! code-gc
-    } pick-one dup . execute terpri ;
-

apps/random-tester/random-tester2.factor

@@ -1,163 +0,0 @@
-USING: compiler errors inference interpreter io
-kernel math memory namespaces prettyprint random-tester
-sequences tools words ;
-USING: arrays definitions generic graphs hashtables ;
-IN: random-tester2
-
-SYMBOL: wordbank
-: w1
-    {
-        die
-        set-walker-hook exit
-
-        xref-words
-
-        times repeat (repeat)
-        supremum infimum assoc rassoc norm-sq
-        product sum curry remove-all member? subseq?
-
-        (next-power-of-2) (^) d>w/w w>h/h millis
-        (random-int) ^n integer, first-bignum
-        most-positive-fixnum ^ init-random next-power-of-2
-        most-negative-fixnum
-
-        clear-hash build-graph
-
-        >r r>
-
-        set-callstack set-word set-word-prop
-        set-catchstack set-namestack set-retainstack
-        set-continuation-retain continuation-catch
-        set-continuation-name catchstack retainstack
-        set-no-math-method-generic
-        set-no-math-method-right
-        set-check-method-class
-        set-check-create-name
-        set-nested-style-stream-style
-        set-pathname-string
-        set-check-create-vocab
-        <check-create> check-create?
-        reset-generic forget-class
-        create forget-word forget-vocab forget forget-tuple
-        remove-word-prop empty-method
-        continue-with <continuation>
-
-        define-compound define make-generic
-        define-method define-predicate-class
-        define-tuple define-temp define-tuple-slots
-        define-writer define-predicate define-generic
-        ?make-generic define-reader define-slot define-slots
-        define-typecheck define-slot-word define-union
-        define-generic* with-methods define-constructor
-        predicate-word condition-continuation define-symbol
-
-        ndrop
-
-        set-word-def set-word-name
-        set-word-props set-word-primitive
-
-        stdio
-        close readln (readln) read1 read with-server
-        stream-read stream-readln stream-read1 lines (lines)
-        contents stream-copy stream-flush
-        stream-format set-line-reader-cr
-
-        double>bits float>bits >bignum
-
-        intern-slots class-predicates delete (delete) prune memq?
-        normalize norm vneg vmax vmin v- v+ [v-]
-
-        bin> oct> le> be> hex> string>number
-
-        gensym random-int counter <byte-array>
-        <word> <client-stream> <server> <client>
-        <duplex-stream> <file-writer> <file-reader> ! <file-r/w>
-        init-namespaces unxref-word set-global set off on
-        nest
-        set-restart-obj
-        +@ inc dec
-
-        changed-words
-        callstack namespace namestack global vocabularies
-
-        path+ parent-dir
-
-        .s . word-xt.
-
-        <continuation> continue-with
-        set-delegate
-
-        closure
-        
-        tabular-output simple-slots
-
-        join concat
-    }
-    { "arrays" "errors" "generic" "graphs" "hashtables" "io"
-    "kernel" "math" "namespaces"
-    "queues" "strings" "sequences" "vectors" "words" }
-    [ words ] map concat diff ;
-
-w1 wordbank set-global
-
-: databank
-    {
-        ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
-        pi 1/0. -1/0. 0/0. [ ]
-        f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
-        C{ 2 2 } C{ 1/0. 1/0. }
-    } ;
-
-: setup-test ( #data #code -- data... quot )
-    #! variable stack effect
-    >r [ databank pick-one ] times r>
-    [ drop wordbank get pick-one ] map >quotation ;
-
-SYMBOL: before
-SYMBOL: after
-SYMBOL: quot
-SYMBOL: err
-err off
-
-: test-compiler ( data... quot -- ... )
-    err off
-    dup quot set
-    datastack clone dup pop* before set
-    [ call ] catch drop datastack clone after set
-    clear
-    before get [ ] each
-    quot get [ compile-1 ] [ err on ] recover ;
-
-: do-test ( data... quot -- )
-    .s flush test-compiler
-    err get [
-        datastack after get 2dup = [
-            2drop
-        ] [
-            [ . ] each
-            "--" print
-            [ . ] each quot get .
-            "not =" throw
-        ] if
-    ] unless
-    clear ;
-
-: random-test ( #data #code -- )
-    setup-test do-test ;
-
-: run-random-tester2
-    100000000000000 [ 6 3 random-test ] times ;
-
-
-! A worthwhile test that has not been run extensively
-1000 [ drop gensym ] map "syms" set
-
-: pick-one [ length random-int ] keep nth ;
-
-: fooify-test
-    "syms" get pick-one
-    2000 random-int >quotation
-    over set-word-def
-    100 random-int zero? [ code-gc ] when
-    compile fooify-test ;
-

apps/random-tester/random.factor

@@ -1,87 +0,0 @@
-USING: kernel math sequences namespaces errors hashtables words
-arrays parser compiler syntax io tools prettyprint optimizer
-inference ;
-IN: random-tester
-
-! Tweak me
-: max-length 15 ; inline
-: max-value 1000000000 ; inline
-
-: 10% ( -- bool ) 10 random-int 8 > ;
-: 20% ( -- bool ) 10 random-int 7 > ;
-: 30% ( -- bool ) 10 random-int 6 > ;
-: 40% ( -- bool ) 10 random-int 5 > ;
-: 50% ( -- bool ) 10 random-int 4 > ;
-: 60% ( -- bool ) 10 random-int 3 > ;
-: 70% ( -- bool ) 10 random-int 2 > ;
-: 80% ( -- bool ) 10 random-int 1 > ;
-: 90% ( -- bool ) 10 random-int 0 > ;
-
-! varying bit-length random number
-: random-bits ( n -- int )
-    random-int 2 swap ^ random-int ;
-
-: random-seq ( -- seq )
-    { [ ] { } V{ } "" } pick-one
-    [ max-length random-int [ max-value random-int , ] times ] swap make ;
-
-: random-string
-    [ max-length random-int [ max-value random-int , ] times ] "" make ;
-
-SYMBOL: special-integers
-[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] 
-{ } make \ special-integers set-global
-: special-integers ( -- seq ) \ special-integers get ;
-SYMBOL: special-floats
-[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
-{ } make \ special-floats set-global
-: special-floats ( -- seq ) \ special-floats get ;
-SYMBOL: special-complexes
-[ 
-    { -1 0 1 i -i } %
-    e , e neg , pi , pi neg ,
-    0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
-    pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
-    e neg e neg rect> , e e rect> ,
-] { } make \ special-complexes set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
-
-: random-fixnum ( -- fixnum )
-    most-positive-fixnum random-int 1+ coin-flip [ neg 1- ] when >fixnum ;
-
-: random-bignum ( -- bignum )
-     400 random-bits first-bignum + coin-flip [ neg ] when ;
-    
-: random-integer ( -- n )
-    coin-flip [
-        random-fixnum
-    ] [
-        coin-flip [ random-bignum ] [ special-integers pick-one ] if
-    ] if ;
-
-: random-positive-integer ( -- int )
-    random-integer dup 0 < [
-            neg
-        ] [
-            dup 0 = [ 1 + ] when
-    ] if ;
-
-: random-ratio ( -- ratio )
-    1000000000 dup [ random-int ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
-
-: random-float ( -- float )
-    coin-flip [ random-ratio ] [ special-floats pick-one ] if
-    coin-flip 
-    [ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if
-    >float ;
-
-: random-number ( -- number )
-    {
-        [ random-integer ]
-        [ random-ratio ]
-        [ random-float ]
-    } do-one ;
-
-: random-complex ( -- C )
-    random-number random-number rect> ;
-

apps/random-tester/type.factor

@@ -1,72 +0,0 @@
-USING: errors generic io kernel lazy-lists math namespaces
-prettyprint random-tester2 sequences tools words ;
-IN: random-tester
-
-: inert ;
-TUPLE: inert-object ;
-
-: inputs ( -- seq )
-    {
-        0 -1 -1000000000000000000000000
-        ! -268435457
-        inert
-            ! T{ inert-object f }
-        -29/2 1000000000000000000000000000000/1111111111111111111111111111111111111111111
-        3/4
-            -1000000000000000000000000/111111111111111111
-        -3.14 1/0. 0.0 -1/0. 3.14 0/0.
-        C{ 1 -1 }
-        W{ 55 }
-        { }
-        f  t
-        H{ }
-        V{ 65536 0 0 0 65536 }
-        ""
-        SBUF" "
-        [ ]
-        ! DLL" libm.dylib"
-        ALIEN: 1
-        T{ inert-object f }
-    } ;
-
-: word-inputs ( word -- seq )
-    [ stack-effect effect-in length ] [ drop 0 ] recover
-    inputs swap ;
-    
-: type-error? ( exception -- ? )
-    [ swap execute or ] curry
-    >r { no-method? no-math-method? } f r> reduce ;
-
-: maybe-explode
-    dup sequence? [ [ ] each ] when ; inline
-
-SYMBOL: err
-SYMBOL: type-error
-SYMBOL: params
-SYMBOL: last-time
-: throws? ( data... quot -- ? )
-    err off type-error off
-    >r
-        dup clone params set
-        maybe-explode
-    r>
-    ! .s
-    dup last-time get = [ dup . flush dup last-time set ] unless
-    [ call ] [ err on ] recover
-    err get [
-        dup type-error? dup [
-            ! .s
-        ] unless
-        type-error set
-    ] when clear type-error get ;
-
-: test-inputs ( word -- seq )
-    [ word-inputs ] keep
-    unit [
-        throws? not clear
-    ] curry each-permutation ;
-
-: test1
-    wordbank get [
-        [ stack-effect effect-in length ] catch [ 4 < ] unless
-    ] subset [ test-inputs ] each ;

apps/random-tester/utils.factor

@@ -1,73 +0,0 @@
-USING: kernel math sequences namespaces errors hashtables words
-arrays parser compiler syntax io optimizer inference shuffle
-tools prettyprint ;
-IN: random-tester
-
-: pick-one ( seq -- elt )
-    [ length random-int ] keep nth ;
-
-! HASHTABLES
-: random-hash-entry ( hash -- key value )
-    hash>alist pick-one first2 ;
-
-: coin-flip ( -- bool ) 2 random-int zero? ;
-: do-one ( seq -- ) pick-one call ; inline
-
-: nzero-array ( seq -- )
-    dup length >r 0 r> [ pick set-nth ] each-with drop ;
-    
-: zero-array
-    [ drop 0 ] map ;
-
-TUPLE: p-list seq max count count-vec ;
-: make-p-list ( seq n -- tuple )
-    >r dup length [ 1- ] keep r>
-    [ ^ 0 swap 2array ] keep
-    zero-array <p-list> ;
-
-: inc-seq ( seq max -- )
-    2dup [ < ] curry find-last over -1 = [
-        3drop nzero-array
-    ] [
-        nipd 1+ 2over swap set-nth
-        1+ over length rot <slice> nzero-array
-    ] if ;
-
-: inc-count ( tuple -- )
-    [ p-list-count first2 >r 1+ r> 2array ] keep
-    set-p-list-count ;
-
-: get-permutation ( tuple -- seq )
-    [ p-list-seq ] keep p-list-count-vec [ swap nth ] map-with ;
-
-: p-list-next ( tuple -- seq/f )
-    dup p-list-count first2 < [
-        [
-            [ get-permutation ] keep 
-            [ p-list-count-vec ] keep p-list-max
-            inc-seq
-        ] keep inc-count
-    ] [
-        drop f
-    ] if ;
-
-: (permutations) ( tuple -- )
-    dup p-list-next [ , (permutations) ] [ drop ] if* ;
-
-: permutations ( seq n -- seq )
-    make-p-list
-    [
-        (permutations)
-    ] { } make ;
-
-: (each-permutation) ( tuple quot -- )
-    over p-list-next [
-        [ rot drop swap call ] 3keep
-        drop (each-permutation)
-    ] [
-        2drop
-    ] if* ; inline
-
-: each-permutation ( seq n quot -- )
-    >r make-p-list r> (each-permutation) ;
-

apps/raytracer.factor

@@ -1,166 +0,0 @@
-! Factor port of the raytracer benchmark from
-! http://www.ffconsultancy.com/free/ray_tracer/languages.html
-
-USING: arrays compiler generic io kernel math namespaces
-sequences test words ;
-IN: ray
-
-! parameters
-: light
-    #! Normalized { -1 -3 2 }.
-    { -0.2672612419124244 -0.8017837257372732 0.5345224838248488 } ; inline
-
-: oversampling 4 ; inline
-
-: levels 3 ; inline
-
-: size 200 ; inline
-
-: delta 1.4901161193847656E-8 ; inline
-
-TUPLE: ray orig dir ;
-
-TUPLE: hit normal lambda ;
-
-GENERIC: intersect-scene ( hit ray scene -- hit )
-
-TUPLE: sphere center radius ;
-
-: sphere-v ( sphere ray -- v )
-    swap sphere-center swap ray-orig v- ; inline
-
-: sphere-b ( ray v -- b ) swap ray-dir v. ; inline
-
-: sphere-disc ( sphere v b -- d )
-    sq swap norm-sq - swap sphere-radius sq + ; inline
-
-: -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
-
-: sphere-b/d ( b d -- t )
-    -+ dup 0.0 < [ 2drop 1.0/0.0 ] [ >r [ 0.0 > ] keep r> ? ] if ; inline
-
-: ray-sphere ( sphere ray -- t )
-    2dup sphere-v tuck sphere-b [ sphere-disc ] keep
-    over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ;
-    inline
-
-: sphere-n ( ray sphere l -- n )
-    pick ray-dir n*v swap sphere-center v- swap ray-orig v+ ;
-    inline
-
-: if-ray-sphere ( hit ray sphere quot -- hit )
-    #! quot: hit ray sphere l -- hit
-    >r pick hit-lambda >r 2dup swap ray-sphere dup r> >=
-    [ 3drop ] r> if ; inline
-
-M: sphere intersect-scene ( hit ray sphere -- hit )
-    [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
-
-TUPLE: group objs ;
-
-C: group ( objs bound -- group )
-    [ set-delegate ] keep [ set-group-objs ] keep ;
-
-: make-group ( bound quot -- )
-    swap >r { } make r> <group> ; inline
-
-M: group intersect-scene ( hit ray group -- hit )
-    [
-        drop
-        group-objs [ >r tuck r> intersect-scene swap ] each
-        drop
-    ] if-ray-sphere ;
-
-: initial-hit T{ hit f { 0.0 0.0 0.0 } 1.0/0.0 } ; inline
-
-: initial-intersect ( ray scene -- hit )
-    initial-hit -rot intersect-scene ; inline
-
-: ray-o ( ray hit -- o )
-    over ray-dir over hit-lambda v*n
-    swap hit-normal delta v*n v+
-    swap ray-orig v+ ; inline
-
-: sray-intersect ( ray scene hit -- ray )
-    swap >r ray-o light vneg <ray> r> initial-intersect ; inline
-
-: ray-g ( hit -- g ) hit-normal light v. ; inline
-
-: cast-ray ( ray scene -- g )
-    2dup initial-intersect dup hit-lambda 1.0/0.0 = [
-        3drop 0.0
-    ] [
-        dup ray-g >r sray-intersect hit-lambda 1.0/0.0 =
-        [ r> neg ] [ r> drop 0.0 ] if
-    ] if ; inline
-
-: create-center ( c r d -- c2 )
-    >r 3.0 12.0 sqrt / * r> n*v v+ ; inline
-
-DEFER: create ( level c r -- scene )
-
-: create-step ( level c r d -- scene )
-    over >r create-center r> 2.0 / >r >r 1 - r> r> create ;
-
-: create-offsets ( quot -- )
-    {
-        { -1.0 1.0 -1.0 }
-        { 1.0 1.0 -1.0 }
-        { -1.0 1.0 1.0 }
-        { 1.0 1.0 1.0 }
-    } swap each ; inline
-
-: create-bound ( c r -- sphere ) 3.0 * <sphere> ;
-
-: create-group ( level c r -- scene )
-    2dup create-bound [
-        2dup <sphere> ,
-        [ >r 3dup r> create-step , ] create-offsets 3drop
-    ] make-group ;
-
-: create ( level c r -- scene )
-    pick 1 = [ <sphere> nip ] [ create-group ] if ;
-
-: ss-point ( dx dy -- point )
-    [ oversampling /f ] 2apply 0.0 3array ;
-
-: ss-grid ( -- ss-grid )
-    oversampling [ oversampling [ ss-point ] map-with ] map ;
-
-: ray-grid ( point ss-grid -- ray-grid )
-    [
-        [ v+ normalize { 0.0 0.0 -4.0 } swap <ray> ] map-with
-    ] map-with ;
-
-: ray-pixel ( scene point -- n )
-    ss-grid ray-grid 0.0 -rot
-    [ [ swap cast-ray + ] each-with ] each-with ;
-
-: pixel-grid ( -- grid )
-    size reverse [
-        size [
-            [ size 0.5 * - ] 2apply swap size >float 3array
-        ] map-with
-    ] map ;
-
-: pgm-header ( w h -- )
-    "P5\n" % swap # " " % # "\n255\n" % ;
-
-: pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
-
-: ray-trace ( scene -- pixels )
-    pixel-grid [ [ ray-pixel ] map-with ] map-with ;
-
-: run ( -- string )
-    levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [
-        size size pgm-header
-        [ [ oversampling sq / pgm-pixel ] each ] each
-    ] "" make ;
-
-: run>file ( file -- )
-    "Generating " write dup write "..." print
-    <file-writer> [ run write ] with-stream ;
-
-PROVIDE: apps/raytracer ;
-
-MAIN: apps/raytracer [ "raytracer.pnm" run>file ] time ;

apps/rss/load.factor

@@ -1,6 +0,0 @@
-REQUIRES: libs/http-client libs/httpd libs/sqlite ;
-PROVIDE: apps/rss
-{ +files+ {
-	"rss.factor"
-	"rss-reader.factor"
-} } ;

apps/rss/readme.txt

@@ -1,32 +0,0 @@
-This library is a simple RSS2 parser and RSS reader web
-application. To run the web application you'll need to make sure you
-have the sqlite library working. This can be tested with
-
-  "contrib/sqlite" require
-  "contrib/sqlite" test-module
-
-Remember that to use "sqlite" you need to have done the following
-somewhere:
-
-  USE: alien
-  "sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
-
-Replacing "libsqlite3.so" with the path to the sqlite shared library
-or DLL. I put this in my ~/.factor-rc.
-
-The RSS reader web application creates a database file called
-'rss-reader.db' in the same directory as the Factor executable when
-first started. This database contains all the feed information.
-
-To load the web application use:
-
-  "contrib/rss" require
-
-Fire up the web server and navigate to the URL:
-
-  http://localhost:8888/responder/maintain-feeds
-
-Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
-update the sqlite database with the feed contains. Use 'Database' to
-view the entries from the database for that feed.
-

apps/rss/rss-reader.factor

@@ -1,128 +0,0 @@
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Create a test database like follows:
-!
-!   sqlite3 history.db
-!   > create table rss (url text, title text, link text, primary key (url));
-!   > create table entries (url text, link text, title text, description text, pubdate text, primary key(url, link));
-!   > [eof]
-!
-IN: rss
-USING: kernel html cont-responder namespaces sequences io hashtables sqlite errors tuple-db ;
-   
-TUPLE: reader-feed url title link ;
-TUPLE: reader-entry url link title description pubdate ;
-
-reader-feed default-mapping set-mapping
-reader-entry default-mapping set-mapping
-
-SYMBOL: db
-
-: init-db ( -- )
-  db get-global [ sqlite-close ] when*
-  "rss-reader.db" exists? [
-    "rss-reader.db" sqlite-open db set-global
-  ] [
-    "rss-reader.db" sqlite-open dup db set-global
-    dup reader-feed create-tuple-table
-    reader-entry create-tuple-table
-  ] if ;
-
-: add-feed ( url -- )
-  "" "" <reader-feed> db get swap insert-tuple ;
-
-: remove-feed ( url -- )
-  f f <reader-feed> db get swap find-tuples [ db get swap delete-tuple ] each ;
-
-: all-urls ( -- urls )
-  f f f <reader-feed> db get swap find-tuples [ reader-feed-url ] map ;
-
-: ask-for-url ( -- url )
-  [
-    <html>
-      <head> <title> "Enter a Feed URL" write </title> </head>
-      <body>
-        <form =action "post" =method form>
-          "URL: " write
-          <input "text" =type "url" =name "100" =size input/>
-          <input "submit" =type input/>
-        </form>
-      </body>
-    </html>
-  ] show "url" swap hash ;
-
-: get-entries ( url -- entries )
-  f f f f <reader-entry> db get swap find-tuples ;
-  
-: display-entries ( url -- )
-  [
-    <html> 
-      <head> <title> "View entries for " write over write </title> </head>
-      <body>
-        swap get-entries [
-         <h2> dup reader-entry-title write </h2>
-         <p>
-           reader-entry-description write
-         </p>        
-        ] each        
-        <p> <a =href a> "Back" write </a> </p>
-      </body>
-    </html>
-  ] show 2drop ;
-
-: rss>reader-feed ( url rss -- reader-feed )
-  [ rss-title ] keep rss-link <reader-feed> ;   
-
-: rss-entry>reader-entry ( url entry -- reader-entry )
-  [ rss-entry-link ] keep
-  [ rss-entry-title ] keep
-  [ rss-entry-description ] keep
-  rss-entry-pub-date 
-  <reader-entry> ;
-
-: update-feed-database ( url -- )
-  dup remove-feed
-  dup rss-get 
-  2dup rss>reader-feed db get swap save-tuple
-  rss-entries [
-    dupd rss-entry>reader-entry
-    dup >r reader-entry-link f f f <reader-entry> db get swap find-tuples [ db get swap delete-tuple ] each r>
-    db get swap save-tuple
-  ] each-with ;
-
-: update-feeds ( seq -- )
-  [ update-feed-database ] each
-  [
-    <html>
-      <head> <title> "Feeds Updated" write </title> </head>
-      <body>
-        <p> "Feeds Updated." write </p>
-        <p> <a =href a> "Back" write </a> </p>
-      </body>
-    </html>          
-  ] show drop ;
-  
-: maintain-feeds ( -- )
-  [
-    <html>
-      <head> <title> "Maintain Feeds" write </title> </head>
-      <body>
-	<p>
-          <table "1" =border table>
-            all-urls [
-              <tr> 
-                <td> dup write </td>
-                <td> dup [ remove-feed ] curry "Remove" swap quot-href </td>
-                <td> [ display-entries ] curry "Database" swap quot-href </td>
-              </tr>
-            ] each
-          </table>
-        </p>
-        <p> "Add Feed" [ ask-for-url add-feed ] quot-href </p>
-        <p> "Update Feeds" [ all-urls update-feeds ] quot-href </p>
-      </body>
-    </html>
-  ] show-final ;
-
-"maintain-feeds" [ init-db maintain-feeds ] install-cont-responder

apps/rss/rss.factor

@@ -1,107 +0,0 @@
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-IN: rss
-USING: kernel http-client sequences namespaces math errors io ;
-
-: (replace) ( str1 str2 string -- )
-  pick over ! str1 str2 string str1 string
-  start dup -1 = [ ! str1 str2 string n
-    drop % 2drop
-  ] [ 
-    dup    ! str1 str2 string n n-1
-    pick swap head % ! str1 str2 string n )
-    >r pick length r> + tail ! str1 str2 tail
-    over % (replace)     
-  ] if ;
-  
-: replace ( str1 str2 string -- string )
-  #! Replace occurences of str1 with str2 inside string.
-  [ (replace) ] "" make ;
-
-: find-start-tag ( tag seq -- n )
-  #! Find the start XML tag in the sequence. Return f if not found.
-  #! If found return the index of the start of the contents of that tag.
-  dup rot "<" swap append swap start dup 0 >= [ ! seq index
-    ">" -rot start* dup 0 >= [ 1 + ] [ drop f ] if
-  ] [
-    2drop f
-  ] if  ;
-
-: find-end-tag ( tag seq -- n )
-  #! Find the end XML tag in the sequence. Return -1 if not found.
-  #! If found return the index of the data following the end tag.
-  #! If found return the index of one beyond the last items of the contents of that tag.
-  swap "</" swap append swap start dup 0 >= [ drop f ] unless ;
-
-: (between-tags) ( tag seq -- content )
-  #! Return a string containing the contents of the XML tag contained in seq. Returns
-  #! false if the tag is not found.
-  [ find-start-tag [ "no start tag" throw ] unless* ] 2keep [ find-end-tag 2dup and ] keep swap [ subseq ] [ 3drop "" ] if ;
-
-: between-tags ( tag seq -- content )
-  [ (between-tags) ] catch [ 3drop "" ] when* ;
-
-: between-tags-index ( tag seq -- start end bool )
-  #! Return the start and end index of the data contained with an xml tag.
-  #! Returns t if a match is found, else f along with the indexes.
-  [ find-start-tag ] 2keep find-end-tag 2dup and ;
-
-: (child-tags) ( list tag seq -- list )
-  2dup between-tags-index ! list tag seq start end bool
-  [
-    dup 1 + >r ! list tag seq start end r: end
-    pick subseq ! list tag seq item r: end
-    -rot >r >r over push r> r> r> ! list tag seq end
-    over length rot subseq  (child-tags) 
-  ] [
-    drop drop drop drop 
-  ] if ;
-  
-: child-tags ( tag seq -- list )
-  #! Return a list of strings, each string containing the contents of all
-  #! child tags in the XML data sequence.
-  V{ } clone -rot (child-tags) ;
-
-TUPLE: rss title link entries ;
-TUPLE: rss-entry title link description pub-date ;
-
-: entities-mapping ( -- entities )
-  {
-    { "&lt;" "<" }
-    { "&gt;" ">" }
-    { "&amp;" "&" }
-    { "&quot;" "\"" }
-    { "&apos;" "'" }
-  } ;
-
-: replace-entities ( string -- string )
-  entities-mapping [ first2 rot replace ] each ;
-
-: non-empty ( str1 str2 -- str )
-  #! Return the string that is not empty.
-  over empty? [ nip ] [ drop ] if ;
-
-: process-rss-string ( string -- rss )
-  "rss" swap between-tags 
-  "channel" swap between-tags
-  [ "title" swap between-tags replace-entities ] keep
-  [ "link" swap between-tags ] keep
-  "item" swap child-tags [
-    [ "title" swap between-tags replace-entities ] keep
-    [ "link" swap between-tags ] keep
-    [ "guid" swap between-tags non-empty ] keep
-    [ "description" swap between-tags replace-entities ] keep
-    "pubDate" swap between-tags <rss-entry>
-  ] map <rss> ;
-
-: load-rss-file ( filename -- rss )
-  #! Load an RSS file and process it, returning it as an rss tuple.
-  <file-reader> [ contents process-rss-string ] keep stream-close ;
-
-: rss-get ( url -- rss )
-  #! Retrieve an RSS file, return as an rss tuple.
-  http-get rot 200 = [
-    nip process-rss-string 
-  ] [
-    2drop "Error retrieving rss file" throw
-  ] if ;

apps/space-invaders/load.factor

@@ -1,11 +0,0 @@
-REQUIRES: libs/parser-combinators libs/concurrency ;
-
-PROVIDE: apps/space-invaders
-{ +files+ {
-	"cpu-8080.factor"
-	"space-invaders.factor"
-} } ;
-
-USE: space-invaders
-
-MAIN: apps/space-invaders run ;

apps/space-invaders/readme.txt

@@ -1,41 +0,0 @@
-This is a simple space invaders emulator. The goal is to produce an
-emulator, disassembler and assembler for the 8080 processor.
-
-It is integrated into the Factor module system, the following will
-load all necessary files and run it:
-
-  "contrib/space-invaders" run-module
-
-For this to work it needs a ROM file called 'invaders.rom' in the
-factor root directory.
-
-'Backspace' inserts a coin, '1' is the one player button and '2' is
-the two play button. The left and right arrow keys move and the up
-arrow key fires.
-
-If the ROM file you have is split into seperate files, you will need
-to merge them into one 'invaders.rom' file. From Windows this is done
-with:
-
-  copy /b invaders.h+invaders.g+invaders.f+invaders.e invaders.rom
-
-Or Linux:
-
-  cat invaders.h invaders.g invaders.f invaders.e >invaders.rom
-
-The emulator is actually a generic Intel 8080 and the code for this is
-in cpu-8080.factor. The space invaders specific code is in
-space-invaders.factor. It specializes generic functions defined by the
-8080 emulator code to handle the space invaders display and
-input/output ports.
-
-Current Issues:
-
-1) The Escape key does not close the GUI. It does stop the CPU
-   emulation process though.
-
-2) The best way of stopping if to just close the GUI window.
-
-For more information, contact the author, Chris Double, at
-chris.double@double.co.nz or from my weblog
-http://www.bluishcoder.co.nz

apps/space-invaders/space-invaders.factor

@@ -1,327 +0,0 @@
-! Copyright (C) 2006 Chris Double.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-USING: alien cpu-8080 errors generic io kernel kernel-internals
-math namespaces sequences styles threads gadgets gadgets opengl arrays 
-concurrency ;
-IN: space-invaders
-
-TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap ;
-
-: dip ( x y quot -- y )
-  #! Showing my Joy roots...
-  swap >r call r> ; inline
-
-: dipd ( x y z quot -- y z )
-  #! Showing my Joy roots...
-  -rot >r >r call r> r> ; inline  
-
-: game-width 224  ; inline
-: game-height 256 ; inline
-
-: make-opengl-bitmap ( -- array )
-  game-height game-width 3 * * "char" <c-array> ;
-
-: bitmap-index ( point -- index )
-  #! Point is a {x y}.
-  first2 game-width 3 * * swap 3 * + ;
-
-: set-bitmap-pixel ( color point array -- )
-  #! 'color' is a {r g b}. Point is {x y}.
-  [ bitmap-index ] dip ! color index array
-  [ [ first ] dipd set-uchar-nth ] 3keep
-  [ [ second ] dipd [ 1 + ] dip set-uchar-nth ] 3keep
-  [ third ] dipd [ 2 + ] dip set-uchar-nth ;
-
-: get-bitmap-pixel ( point array -- color )
-  #! Point is a {x y}. color is a {r g b} 
-  [ bitmap-index ] dip
-  [ uint-nth ] 2keep
-  [ [ 1 + ] dip uchar-nth ] 2keep
-  [ 2 + ] dip uchar-nth 3array ;
-  
-C: space-invaders ( -- cpu )
-  [ <cpu> swap set-delegate ] keep
-  [ make-opengl-bitmap swap set-space-invaders-bitmap ] keep
-  [ reset ] keep ;
-
-: read-port1 ( cpu -- byte )
-  #! Port 1 maps the keys for space invaders
-  #! Bit 0 = coin slot
-  #! Bit 1 = two players button
-  #! Bit 2 = one player button
-  #! Bit 4 = player one fire
-  #! Bit 5 = player one left
-  #! Bit 6 = player one right
-  [ space-invaders-port1 dup HEX: FE bitand ] keep 
- set-space-invaders-port1 ;
-
-: read-port2 ( cpu -- byte )
-  #! Port 2 maps player 2 controls and dip switches
-  #! Bit 0,1 = number of ships
-  #! Bit 2   = mode (1=easy, 0=hard)
-  #! Bit 4   = player two fire
-  #! Bit 5   = player two left
-  #! Bit 6   = player two right
-  #! Bit 7   = show or hide coin info
-  [ space-invaders-port2i HEX: 8F bitand ] keep 
-  space-invaders-port1 HEX: 70 bitand bitor ;
-
-: read-port3 ( cpu -- byte )
-  #! Used to compute a special formula
-  [ space-invaders-port4hi 8 shift ] keep 
-  [ space-invaders-port4lo bitor ] keep 
-  space-invaders-port2o shift -8 shift HEX: FF bitand ;
-
-M: space-invaders read-port ( port cpu -- byte )
-  #! Read a byte from the hardware port. 'port' should
-  #! be an 8-bit value.
-  {
-    { [ over 1 = ] [ nip read-port1 ] }
-    { [ over 2 = ] [ nip read-port2 ] }
-    { [ over 3 = ] [ nip read-port3 ] }
-    { [ t ]        [ 2drop 0 ] }    
-  } cond ;
-
-: write-port2 ( value cpu -- )
-  #! Setting this value affects the value read from port 3
-  set-space-invaders-port2o ;
-
-: write-port3 ( value cpu -- )
-  #! Connected to the sound hardware
-  #! Bit 0 = spaceship sound (looped)
-  #! Bit 1 = Shot 
-  #! Bit 2 = Your ship hit
-  #! Bit 3 = Invader hit
-  #! Bit 4 = Extended play sound
-  set-space-invaders-port3o ;
-
-: write-port4 ( value cpu -- )
-  #! Affects the value returned by reading port 3
-  [ space-invaders-port4hi ] keep 
-  [ set-space-invaders-port4lo ] keep 
-  set-space-invaders-port4hi ;
-
-: write-port5 ( value cpu -- )
-  #! Plays sounds
-  #! Bit 0 = invaders sound 1
-  #! Bit 1 = invaders sound 2
-  #! Bit 2 = invaders sound 3
-  #! Bit 3 = invaders sound 4
-  #! Bit 4 = spaceship hit 
-  #! Bit 5 = amplifier enabled/disabled
-  set-space-invaders-port5o ;
-
-M: space-invaders write-port ( value port cpu -- )
-  #! Write a byte to the hardware port, where 'port' is
-  #! an 8-bit value.  
-  {
-    { [ over 2 = ] [ nip write-port2 ] }
-    { [ over 3 = ] [ nip write-port3 ] }
-    { [ over 4 = ] [ nip write-port4 ] }
-    { [ over 5 = ] [ nip write-port5 ] }
-    { [ t ]        [ 3drop ] }
-  } cond ;
-
-M: space-invaders reset ( cpu -- )
-  [ delegate reset ] keep
-  [ 0 swap set-space-invaders-port1 ] keep
-  [ 0 swap set-space-invaders-port2i ] keep
-  [ 0 swap set-space-invaders-port2o ] keep
-  [ 0 swap set-space-invaders-port3o ] keep
-  [ 0 swap set-space-invaders-port4lo ] keep
-  [ 0 swap set-space-invaders-port4hi ] keep
-  0 swap set-space-invaders-port5o ;
-
-: gui-step ( cpu -- )
-  [ read-instruction ] keep ! n cpu
-  over get-cycles over inc-cycles
-  [ swap instructions dispatch ] keep  
-  [ cpu-pc HEX: FFFF bitand ] keep 
-  set-cpu-pc ;
-
-: gui-frame/2 ( cpu -- )
-  [ gui-step ] keep
-  [ cpu-cycles ] keep
-  over 16667 < [ ! cycles cpu
-    nip gui-frame/2
-  ] [
-    [ >r 16667 - r> set-cpu-cycles ] keep
-    dup cpu-last-interrupt HEX: 10 = [
-      HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
-    ] [
-      HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
-    ] if     
-  ] if ;
-
-: gui-frame ( cpu -- )
-  dup gui-frame/2 gui-frame/2 ;
-
-: coin-down ( cpu -- )
-  [ space-invaders-port1 1 bitor ] keep set-space-invaders-port1 ;
-
-: coin-up ( cpu --  )
-  [ space-invaders-port1 255 1 - bitand ] keep set-space-invaders-port1 ;
-
-: player1-down ( cpu -- )
-  [ space-invaders-port1 4 bitor ] keep set-space-invaders-port1 ;
-
-: player1-up ( cpu -- )
-  [ space-invaders-port1 255 4 - bitand ] keep set-space-invaders-port1 ;
-
-: player2-down ( cpu -- )
-  [ space-invaders-port1 2 bitor ] keep set-space-invaders-port1 ;
-
-: player2-up ( cpu -- )
-  [ space-invaders-port1 255 2 - bitand ] keep set-space-invaders-port1 ;
-
-: fire-down ( cpu -- )
-  [ space-invaders-port1 HEX: 10 bitor ] keep set-space-invaders-port1 ;
-
-: fire-up ( cpu -- )
-  [ space-invaders-port1 255 HEX: 10 - bitand ] keep set-space-invaders-port1 ;
-
-: left-down ( cpu -- )
-  [ space-invaders-port1 HEX: 20 bitor ] keep set-space-invaders-port1 ;
-
-: left-up ( cpu -- )
-  [ space-invaders-port1 255 HEX: 20 - bitand ] keep set-space-invaders-port1 ;
-
-: right-down ( cpu -- )
-  [ space-invaders-port1 HEX: 40 bitor ] keep set-space-invaders-port1 ;
-
-: right-up ( cpu -- )
-  [ space-invaders-port1 255 HEX: 40 - bitand ] keep set-space-invaders-port1 ;
-
-
-TUPLE: invaders-gadget cpu quit? ;
-
-invaders-gadget H{
-    { T{ key-down f f "ESCAPE" }    [ t swap set-invaders-gadget-quit? ] }
-    { T{ key-down f f "BACKSPACE" } [ invaders-gadget-cpu coin-down ] }
-    { T{ key-up   f f "BACKSPACE" } [ invaders-gadget-cpu coin-up ] }
-    { T{ key-down f f "1" }         [ invaders-gadget-cpu player1-down ] }
-    { T{ key-up   f f "1" }         [ invaders-gadget-cpu player1-up ] }
-    { T{ key-down f f "2" }         [ invaders-gadget-cpu player2-down ] }
-    { T{ key-up   f f "2" }         [ invaders-gadget-cpu player2-up ] }
-    { T{ key-down f f "UP" }        [ invaders-gadget-cpu fire-down ] }
-    { T{ key-up   f f "UP" }        [ invaders-gadget-cpu fire-up ] }
-    { T{ key-down f f "LEFT" }      [ invaders-gadget-cpu left-down ] }
-    { T{ key-up   f f "LEFT" }      [ invaders-gadget-cpu left-up ] }
-    { T{ key-down f f "RIGHT" }     [ invaders-gadget-cpu right-down ] }
-    { T{ key-up   f f "RIGHT" }     [ invaders-gadget-cpu right-up ] }
-  } set-gestures 
-
-C: invaders-gadget ( cpu -- gadget ) 
-  [ set-invaders-gadget-cpu ] keep
-  [ f swap set-invaders-gadget-quit? ] keep
-  [ delegate>gadget ] keep ;
-
-M: invaders-gadget pref-dim* drop { 224 256 0 } ;
-
-M: invaders-gadget draw-gadget* ( gadget -- )
-  0 0 glRasterPos2i
-  1.0 -1.0 glPixelZoom
-  >r 224 256 GL_RGB GL_UNSIGNED_BYTE r>
-  invaders-gadget-cpu space-invaders-bitmap glDrawPixels ;
-
-: black { 0 0 0 } ;
-: white { 255 255 255 } ;
-: green { 0 255 0 } ;
-: red   { 255 0 0 } ;
-
-: addr>xy ( addr -- point )
-  #! Convert video RAM address to base X Y value. point is a {x y}.
-  HEX: 2400 - ! n
-  dup HEX: 1f bitand 8 * 255 swap - ! n y
-  swap -5 shift swap 2array ;
-
-: plot-bitmap-pixel ( bitmap point color -- )
-  #! point is a {x y}. color is a {r g b}.
-  swap rot set-bitmap-pixel ;
-
-: within ( n a b -- bool )
-  #! n >= a and n <= b
-  rot tuck swap <= >r swap >= r> and ;
-
-: get-point-color ( point -- color )
-  #! Return the color to use for the given x/y position.
-  first2
-  {
-    { [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
-    { [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
-    { [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
-    { [ t ] [ 2drop white ] }
-  } cond ;
-
-: plot-bitmap-bits ( bitmap point byte bit -- )
-  #! point is a {x y}.
-  [ first2 ] dipd
-  dup swapd -1 * shift 1 bitand 0 =
-  [ - 2array ] dip
-  [ black ] [ dup get-point-color ] if
-  plot-bitmap-pixel ;
-
-: do-bitmap-update ( bitmap value addr -- )
-  addr>xy swap 
-  [ 0 plot-bitmap-bits ] 3keep
-  [ 1 plot-bitmap-bits ] 3keep
-  [ 2 plot-bitmap-bits ] 3keep
-  [ 3 plot-bitmap-bits ] 3keep
-  [ 4 plot-bitmap-bits ] 3keep
-  [ 5 plot-bitmap-bits ] 3keep
-  [ 6 plot-bitmap-bits ] 3keep
-  7 plot-bitmap-bits ;
-
-M: space-invaders update-video ( value addr cpu -- )  
-  over HEX: 2400 >= [
-    space-invaders-bitmap -rot do-bitmap-update
-  ] [
-    3drop
-  ] if ;
-
-: sync-frame ( millis -- millis )
-  #! Sleep until the time for the next frame arrives.
-  1000 60 / >fixnum + millis - dup 0 >
-  [ sleep ] [ drop yield ] if millis ;
-
-: invaders-process ( millis gadget -- )
-  #! Run a space invaders gadget inside a 
-  #! concurrent process. Messages can be sent to
-  #! signal key presses, etc.
-  dup invaders-gadget-quit? [
-    [ sync-frame ] dip
-    [ invaders-gadget-cpu gui-frame ] keep
-    [ relayout-1 ] keep
-    invaders-process 
-  ] unless ;
-
-M: invaders-gadget graft* ( gadget -- )
- [ f swap set-invaders-gadget-quit? ] keep
- [ millis swap invaders-process ] spawn 2drop ;
-
-M: invaders-gadget ungraft* ( gadget -- )
- t swap set-invaders-gadget-quit? ;
-
-: run ( -- )  
-  <space-invaders> "apps/space-invaders/invaders.rom" resource-path over load-rom <invaders-gadget> 
-  "Space Invaders" open-titled-window ;

apps/tetris/README.txt

@@ -1,24 +0,0 @@
-This is a simple tetris game. To play, open factor (in GUI mode), and run:
-
-"contrib/tetris" run-module
-
-This should open a new window with a running tetris game. The commands are:
-
-left, right arrows: move the current piece left or right
-up arrow:           rotate the piece clockwise
-down arrow:         lower the piece one row
-space bar:          drop the piece
-p:                  pause/unpause
-n:                  start a new game
-q:                  quit (currently just stops updating, see TODO)
-
-Running tetris-window will leave a tetris-gadget on your stack. To get your
-current score you can do:
-
-tetris-gadget-tetris tetris-score
-
-TODO:
-- close the window on quit
-- rotation of pieces when they're on the far right of the board
-- show the score and level, maybe floating about the screen somewhere
-- make blocks prettier

apps/tetris/load.factor

@@ -1,24 +0,0 @@
-! Copyright (C) 2006 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-
-REQUIRES: libs/lazy-lists ;
-
-PROVIDE: apps/tetris
-{ +files+ {
-    "tetris-colours.factor"
-    "tetromino.factor"
-    "tetris-piece.factor"
-    "tetris-board.factor"
-    "tetris.factor"
-    "tetris-gl.factor"
-    "tetris-gadget.factor"
-} }
-{ +tests+ {
-    "test/tetris-piece.factor"
-    "test/tetris-board.factor"
-    "test/tetris.factor"
-} } ;
-
-USE: tetris-gadget
-
-MAIN: apps/tetris tetris-window ;

apps/tetris/test/tetris-board.factor

@@ -1,23 +0,0 @@
-USING: kernel tetris-colours tetris-board tetris-piece test arrays ;
-
-[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test
-[ { { f f } { f f } { f f } } ] [ 2 3 <board> board-rows ] unit-test
-[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
-[ f ] [ 2 3 <board> { 1 1 } board-block ] unit-test
-[ 2 3 <board> { 2 3 } board-block ] unit-test-fails
-red 1array [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test
-[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 2 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red board-set-block { 0 1 } block-free? ] unit-test
-[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
-[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
-[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
-[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
-[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } location-valid? ] unit-test
-[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
-[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } over set-piece-location piece-valid? ] unit-test
-[ { { f } { f } } ] [ 1 1 <board> dup add-row board-rows ] unit-test
-[ { { f } } ] [ 1 2 <board> dup { 0 1 } red board-set-block dup remove-full-rows board-rows ] unit-test
-[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red board-set-block dup check-rows drop board-rows ] unit-test

apps/tetris/test/tetris-piece.factor

@@ -1,23 +0,0 @@
-USING: kernel tetromino tetris-piece test sequences arrays namespaces ;
-
-! Tests for tetromino and tetris-piece, since there's not much to test in tetromino
-
-! these two tests rely on the first rotation of the first tetromino being the
-! 'I' tetromino in its vertical orientation.
-[ 4 ] [ tetrominoes get first tetromino-states first blocks-width ] unit-test
-[ 1 ] [ tetrominoes get first tetromino-states first blocks-height ] unit-test
-
-[ { 0 0 } ] [ random-tetromino <piece> piece-location ] unit-test
-[ 0 ] [ 10 <random-piece> piece-rotation ] unit-test
-
-[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ]
-[ tetrominoes get first <piece> piece-blocks ] unit-test
-
-[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ]
-[ tetrominoes get first <piece> dup 1 rotate-piece piece-blocks ] unit-test
-
-[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ]
-[ tetrominoes get first <piece> dup { 1 1 } move-piece piece-blocks ] unit-test
-
-[ 3 ] [ tetrominoes get second <piece> piece-width ] unit-test
-[ 2 ] [ tetrominoes get second <piece> dup 1 rotate-piece piece-width ] unit-test

apps/tetris/test/tetris.factor

@@ -1,16 +0,0 @@
-USING: kernel tetris tetris-board tetris-piece test sequences ;
-
-[ t ] [ <default-tetris> dup tetris-current-piece swap tetris-next-piece and t f ? ] unit-test
-[ t ] [ <default-tetris> { 1 1 } can-move? ] unit-test
-[ t ] [ <default-tetris> { 1 1 } tetris-move ] unit-test
-[ 1 ] [ <default-tetris> dup { 1 1 } tetris-move drop tetris-current-piece piece-location second ] unit-test
-[ 1 ] [ <default-tetris> tetris-level ] unit-test
-[ 1 ] [ <default-tetris> 9 over set-tetris-rows tetris-level ] unit-test
-[ 2 ] [ <default-tetris> 10 over set-tetris-rows tetris-level ] unit-test
-[ 0 ] [ 3 0 rows-score ] unit-test
-[ 80 ] [ 1 1 rows-score ] unit-test
-[ 4800 ] [ 3 4 rows-score ] unit-test
-[ 1 5 rows-score ] unit-test-fails
-[ 1 ] [ <default-tetris> dup 3 score-rows dup 3 score-rows dup 3 score-rows tetris-level ] unit-test
-[ 2 ] [ <default-tetris> dup 4 score-rows dup 4 score-rows dup 2 score-rows tetris-level ] unit-test
-

apps/tetris/tetris-board.factor

@@ -1,59 +0,0 @@
-! Copyright (C) 2006 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays tetris-piece math ;
-IN: tetris-board
-
-TUPLE: board width height rows ;
-
-: make-rows ( width height -- rows )
-    [ drop f <array> ] map-with ;
-
-C: board ( width height -- board )
-    >r 2dup make-rows r>
-    [ set-board-rows ] keep
-    [ set-board-height ] keep
-    [ set-board-width ] keep ;
-
-#! A block is simply an array of form { x y } where { 0 0 } is the top-left of
-#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
-
-: board@block ( board block -- n row )
-    [ second swap board-rows nth ] keep first swap ;
-
-: board-set-block ( board block colour -- ) -rot board@block set-nth ;
-  
-: board-block ( board block -- colour ) board@block nth ;
-
-: block-free? ( board block -- ? ) board-block not ;
-
-: block-in-bounds? ( board block -- ? )
-    [ first swap board-width bounds-check? ] 2keep
-    second swap board-height bounds-check? and ;
-
-: location-valid? ( board block -- ? )
-    2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
-
-: piece-valid? ( board piece -- ? )
-    piece-blocks [ location-valid? ] all-with? ;
-
-: row-not-full? ( row -- ? ) f swap member? ;
-
-: add-row ( board -- )
-    dup board-rows over board-width f <array>
-    add* swap set-board-rows ;
-
-: top-up-rows ( board -- )
-    dup board-height over board-rows length = [
-	drop
-    ] [
-	dup add-row top-up-rows
-    ] if ;
-
-: remove-full-rows ( board -- )
-    dup board-rows [ row-not-full? ] subset swap set-board-rows ;
-
-: check-rows ( board -- n )
-    #! remove full rows, then add blank ones at the top, returning the number
-    #! of rows removed (and added)
-    dup remove-full-rows dup board-height over board-rows length - >r top-up-rows r> ;
-

apps/tetris/tetris-colours.factor

@@ -1,16 +0,0 @@
-! Copyright (C) 2006 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ;
-IN: tetris-colours
-
-: red     { 0.941 0 0 1 } ; inline
-: grey    { 0.5 0.5 0.5 1 } ; inline
-: black   { 0 0 0 1 } ; inline
-: yellow  { 0.941 0.941 0 1 } ; inline
-: orange  { 0.941 0.627 0 1 } ; inline
-: green   { 0 0.941 0 1 } ; inline
-: blue    { 0 0 0.941 1 } ; inline
-: magenta { 0.941 0 0.941 1 } ; inline
-: cyan    { 0 0.941 0.941 1 } ; inline
-: purple  { 0.627 0 0.941 1 } ; inline
-

apps/tetris/tetris-gadget.factor

@@ -1,50 +0,0 @@
-! Copyright (C) 2006 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic gadgets tetris tetris-gl sequences threads arrays ;
-IN: tetris-gadget
-
-TUPLE: tetris-gadget tetris quit? ;
-
-C: tetris-gadget ( tetris -- gadget )
-    [ set-tetris-gadget-tetris ] keep
-    [ f swap set-tetris-gadget-quit? ] keep
-    [ delegate>gadget ] keep ;
-
-M: tetris-gadget pref-dim* drop { 200 400 } ;
-
-M: tetris-gadget draw-gadget* ( gadget -- )
-    ! TODO: show score, level, etc.
-    dup rect-dim dup first swap second rot tetris-gadget-tetris draw-tetris ;
-
-: new-tetris ( gadget -- )
-    dup tetris-gadget-tetris <new-tetris> swap set-tetris-gadget-tetris ;
-
-tetris-gadget H{
-    { T{ key-down f f "ESCAPE" } [ t swap set-tetris-gadget-quit? ] }
-    { T{ key-down f f "q" }      [ t swap set-tetris-gadget-quit? ] }
-    { T{ key-down f f "UP" }     [ tetris-gadget-tetris rotate ] }
-    { T{ key-down f f "LEFT" }   [ tetris-gadget-tetris move-left ] }
-    { T{ key-down f f "RIGHT" }  [ tetris-gadget-tetris move-right ] }
-    { T{ key-down f f "DOWN" }   [ tetris-gadget-tetris move-down ] }
-    { T{ key-down f f " " }      [ tetris-gadget-tetris move-drop ] }
-    { T{ key-down f f "p" }      [ tetris-gadget-tetris toggle-pause ] }
-    { T{ key-down f f "n" }      [ new-tetris ] }
-} set-gestures
-
-: tetris-process ( gadget -- )
-    dup tetris-gadget-quit? [
-	10 sleep
-	dup tetris-gadget-tetris maybe-update
-	[ relayout-1 ] keep
-	tetris-process
-    ] unless ;
-
-M: tetris-gadget graft* ( gadget -- )
-    f over set-tetris-gadget-quit?
-    [ tetris-process ] in-thread drop ;
-
-M: tetris-gadget ungraft* ( gadget -- )
-    t swap set-tetris-gadget-quit? ;
-
-: tetris-window ( -- ) <default-tetris> <tetris-gadget> "Tetris" open-titled-window ;
-

apps/tetris/tetris-gl.factor

@@ -1,44 +0,0 @@
-! Copyright (C) 2006 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays math namespaces opengl gadgets tetris tetris-board tetris-piece tetromino ;
-IN: tetris-gl
-
-#! OpenGL rendering for tetris
-
-: draw-block ( block -- )
-    dup { 1 1 } v+ gl-fill-rect ;
-
-: draw-piece-blocks ( piece -- )
-    piece-blocks [ draw-block ] each ;
-
-: draw-piece ( piece -- )
-    dup tetromino-colour gl-color draw-piece-blocks ;
-
-: draw-next-piece ( piece -- )
-    dup tetromino-colour clone 0.1 3 pick set-nth gl-color draw-piece-blocks ;
-
-! TODO: move implementation specific stuff into tetris-board
-: (draw-row) ( y row x -- y )
-    swap dupd nth [ gl-color over 2array draw-block ] [ drop ] if* ;
-
-: draw-row ( y row -- )
-    dup length [ (draw-row) ] each-with drop ;
-
-: draw-board ( board -- )
-    board-rows dup length [ tuck swap nth draw-row ] each-with ;
-
-: scale-tetris ( width height tetris -- )
-    [ board-width swap ] keep board-height / -rot / swap 1 glScalef ;
-
-: (draw-tetris) ( width height tetris -- )
-    #! width and height are in pixels
-    GL_MODELVIEW [
-        [ scale-tetris ] keep
-	GL_COLOR_BUFFER_BIT glClear
-	dup tetris-board draw-board
-        dup tetris-next-piece draw-next-piece
-	tetris-current-piece draw-piece
-    ] do-matrix ;
-
-: draw-tetris ( width height tetris -- )
-    origin get [ (draw-tetris) ] with-translation ;

apps/tetris/tetris-piece.factor

@@ -1,46 +0,0 @@
-! Copyright (C) 2006 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic arrays tetromino math sequences lazy-lists ;
-IN: tetris-piece
-
-#! A piece adds state to the tetromino that is the piece's delegate. The
-#! rotation is an index into the tetromino's states array, and the position is
-#! added to the tetromino's blocks to give them their location on the tetris
-#! board. If the location is f then the piece is not yet on the board.
-TUPLE: piece rotation location ;
-
-C: piece ( tetromino -- piece )
-    [ set-delegate ] keep
-    0 over set-piece-rotation
-    { 0 0 } over set-piece-location ;
-
-: (piece-blocks) ( piece -- blocks )
-    #! rotates the tetromino
-    dup tetromino-states swap piece-rotation swap nth ;
-
-: piece-blocks ( piece -- blocks )
-    #! rotates and positions the tetromino
-    dup piece-location swap (piece-blocks) [ v+ ] map-with ;
-
-: piece-width ( piece -- width )
-    piece-blocks blocks-width ;
-
-: set-start-location ( piece board-width -- )
-    2 / floor over piece-width 2 / floor - 0 2array swap set-piece-location ;
-
-: <random-piece> ( board-width -- piece )
-    random-tetromino <piece> [ swap set-start-location ] keep ;
-
-: <piece-llist> ( board-width -- llist )
-    [ [ <random-piece> ] curry ] keep [ <piece-llist> ] curry lazy-cons ;
-
-: modulo ( n m -- n )
-  #! -2 7 mod => -2, -2 7 modulo =>  5
-  tuck mod over + swap mod ;
-
-: rotate-piece ( piece inc -- )
-    over piece-rotation + over tetromino-states length modulo swap set-piece-rotation ;
-
-: move-piece ( piece move -- )
-    over piece-location v+ swap set-piece-location ;
-

apps/tetris/tetris.factor

@@ -1,114 +0,0 @@
-! Copyright (C) 2006 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic sequences math tetris-board tetris-piece tetromino errors lazy-lists ;
-IN: tetris
-
-TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
-
-: default-width 10 ; inline
-: default-height 20 ; inline
-
-C: tetris ( width height -- tetris )
-    >r <board> r> [ set-delegate ] keep
-    dup board-width <piece-llist> over set-tetris-pieces
-    0 over set-tetris-last-update
-    0 over set-tetris-rows
-    0 over set-tetris-score
-    f over set-tetris-paused?
-    t over set-tetris-running? ;
-
-: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
-
-: <new-tetris> ( old -- new )
-    [ board-width ] keep board-height <tetris> ;
-
-: tetris-board ( tetris -- board ) delegate ;
-
-: tetris-current-piece ( tetris -- piece ) tetris-pieces car ;
-
-: tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ;
-
-: toggle-pause ( tetris -- )
-    dup tetris-paused? not swap set-tetris-paused? ;
-
-: tetris-level ( tetris -- level )
-    tetris-rows 1+ 10 / ceiling ;
-
-: tetris-update-interval ( tetris -- interval )
-    tetris-level 1- 60 * 1000 swap - ;
-
-: add-block ( tetris block -- )
-    over tetris-current-piece tetromino-colour board-set-block ;
-
-: game-over? ( tetris -- ? )
-    dup dup tetris-next-piece piece-valid? ;
-
-: new-current-piece ( tetris -- )
-    game-over? [
-        dup tetris-pieces cdr swap set-tetris-pieces
-    ] [
-        f swap set-tetris-running?
-    ] if ;
-
-: rows-score ( level n -- score )
-    {
-	{ [ dup 0 = ] [ drop 0 ]    }
-	{ [ dup 1 = ] [ drop 40 ]   }
-	{ [ dup 2 = ] [ drop 100 ]  }
-	{ [ dup 3 = ] [ drop 300 ]  }
-	{ [ dup 4 = ] [ drop 1200 ] }
-	{ [ t ] [ "how did you clear that many rows?" throw ] }
-    } cond swap 1+ * ;
-
-: add-score ( tetris score -- )
-    over tetris-score + swap set-tetris-score ;
-
-: score-rows ( tetris n -- )
-    2dup >r dup tetris-level r> rows-score add-score
-    over tetris-rows + swap set-tetris-rows ;
-
-: lock-piece ( tetris -- )
-    [ dup tetris-current-piece piece-blocks [ add-block ] each-with ] keep
-    dup new-current-piece dup check-rows score-rows ;
-
-: can-rotate? ( tetris -- ? )
-    dup tetris-current-piece clone dup 1 rotate-piece piece-valid? ;
-
-: (rotate) ( inc tetris -- )
-    dup can-rotate? [ tetris-current-piece swap rotate-piece ] [ 2drop ] if ;
-
-: rotate ( tetris -- ) 1 swap (rotate) ;
-
-: can-move? ( tetris move -- ? )
-    >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
-
-: tetris-move ( tetris move -- ? )
-    #! moves the piece if possible, returns whether the piece was moved
-    2dup can-move? [
-	>r tetris-current-piece r> move-piece t
-    ] [
-	2drop f
-    ] if ;
-
-: move-left ( tetris -- ) { -1 0 } tetris-move drop ;
-
-: move-right ( tetris -- ) { 1 0 } tetris-move drop ;
-
-: move-down ( tetris -- )
-    dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
-
-: move-drop ( tetris -- )
-    dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
-
-: can-move? ( tetris move -- ? )
-    >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
-
-: update ( tetris -- )
-    millis over tetris-last-update -
-    over tetris-update-interval > [
-	dup move-down
-	millis swap set-tetris-last-update
-    ] [ drop ] if ;
-
-: maybe-update ( tetris -- )
-    dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ;

apps/tetris/tetromino.factor

@@ -1,113 +0,0 @@
-! Copyright (C) 2006 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays namespaces sequences math tetris-colours ;
-IN: tetromino
-
-TUPLE: tetromino states colour ;
-
-SYMBOL: tetrominoes
-
-{
-  [
-    { {
-	{ 0 0 } { 1 0 } { 2 0 } { 3 0 }
-      } 
-      { { 0 0 }
-        { 0 1 }
-        { 0 2 }
-        { 0 3 }
-      }
-    } cyan
-  ] [
-    {
-      {         { 1 0 }
-	{ 0 1 } { 1 1 } { 2 1 }
-      } {
-	{ 0 0 }
-	{ 0 1 } { 1 1 }
-	{ 0 2 }
-      } {
-	{ 0 0 } { 1 0 } { 2 0 }
-		{ 1 1 }
-      } {
-		{ 1 0 }
-	{ 0 1 } { 1 1 }
-		{ 1 2 }
-      }
-    } purple
-  ] [
-    { { { 0 0 } { 1 0 }
-        { 0 1 } { 1 1 } }
-    } yellow
-  ] [
-    {
-      { { 0 0 } { 1 0 } { 2 0 }
-	{ 0 1 }
-      } {
-	{ 0 0 } { 1 0 }
-	        { 1 1 }
-		{ 1 2 }
-      } {
-	                { 2 0 }
-	{ 0 1 } { 1 1 } { 2 1 }
-      } {
-	{ 0 0 }
-	{ 0 1 }
-	{ 0 2 } { 1 2 }
-      }
-    } orange
-  ] [
-    { 
-      { { 0 0 } { 1 0 } { 2 0 }
-			{ 2 1 }
-      } {
-	        { 1 0 }
-	        { 1 1 }
-	{ 0 2 } { 1 2 }
-      } {
-	{ 0 0 }
-	{ 0 1 } { 1 1 } { 2 1 }
-      } {
-	{ 0 0 } { 1 0 }
-	{ 0 1 }
-	{ 0 2 }
-      }
-    } blue
-  ] [
-    {
-      {          { 1 0 } { 2 0 }
-	{ 0 1 } { 1 1 }
-      } {
-	{ 0 0 }
-	{ 0 1 } { 1 1 }
-		{ 1 2 }
-      }
-    } green
-  ] [
-    {
-      {
-	{ 0 0 } { 1 0 }
-		{ 1 1 } { 2 1 }
-      } {
-		{ 1 0 }
-	{ 0 1 } { 1 1 }
-	{ 0 2 }
-      }
-    } red
-  ]
-} [ call <tetromino> ] map tetrominoes set-global
-
-: random-tetromino ( -- tetromino )
-  tetrominoes get dup length random-int swap nth ;
-
-: blocks-max ( blocks quot -- max )
-    ! add 1 to each block since they are 0 indexed
-    ! [ 1+ ] append map 0 [ max ] reduce ;
-    map [ 1+ ] map 0 [ max ] reduce ;
-
-: blocks-width ( blocks -- width )
-    [ first ] blocks-max ;
-
-: blocks-height ( blocks -- height )
-    [ second ] blocks-max ;
-

apps/turing.factor

@@ -1,72 +0,0 @@
-IN: turing
-USING: arrays hashtables io kernel math namespaces
-prettyprint sequences strings vectors words ;
-
-! A turing machine simulator.
-
-TUPLE: state sym dir next ;
-
-! Mapping from symbol/state pairs into new-state tuples
-SYMBOL: states
-
-! Halting state
-SYMBOL: halt
-
-! This is a simple program that outputs 5 1's
-H{
-    { { 1 0 } T{ state f 1  1 2    } }
-    { { 2 0 } T{ state f 1  1 3    } }
-    { { 3 0 } T{ state f 1 -1 1    } }
-    { { 1 1 } T{ state f 1 -1 2    } }
-    { { 2 1 } T{ state f 1 -1 3    } }
-    { { 3 1 } T{ state f 1 -1 halt } }
-} states set
-
-! Current state
-SYMBOL: state
-
-! Initial state
-1 state set
-
-! Position of head on tape
-SYMBOL: position
-
-! Initial tape position
-5 position set
-
-! The tape, a mutable sequence of some kind
-SYMBOL: tape
-
-! Initial tape
-20 0 <array> >vector tape set
-
-: sym ( -- sym )
-    #! Symbol at head position.
-    position get tape get nth ;
-
-: set-sym ( sym -- )
-    #! Set symbol at head position.
-    position get tape get set-nth ;
-
-: next-state ( -- state )
-    #! Look up the next state/symbol/direction triplet.
-    state get sym 2array states get hash ;
-
-: turing-step ( -- )
-    #! Do one step of the turing machine.
-    next-state
-    dup state-sym set-sym
-    dup state-dir position [ + ] change
-    state-next state set ;
-
-: c
-    #! Print current turing machine state.
-    state get .
-    tape get .
-    2 position get 2 * + CHAR: \s <string> write "^" print ;
-
-: n
-    #! Do one step and print new state.
-    turing-step c ;
-
-PROVIDE: apps/turing ;

basis/alien/arrays/arrays.factor

@@ -0,0 +1,65 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.accessors alien.c-types alien.strings
+arrays compiler.units cpu.architecture fry io.encodings.binary
+io.encodings.utf8 kernel math sequences words ;
+IN: alien.arrays
+
+INSTANCE: array value-type
+
+M: array lookup-c-type ;
+
+M: array c-type-class drop object ;
+
+M: array c-type-boxed-class drop object ;
+
+: array-length ( seq -- n )
+    [ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
+
+M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
+
+M: array c-type-align first c-type-align ;
+
+M: array c-type-align-first first c-type-align-first ;
+
+M: array base-type drop void* base-type ;
+
+PREDICATE: string-type < pair
+    first2 [ c-string = ] [ word? ] bi* and ;
+
+M: string-type lookup-c-type ;
+
+M: string-type c-type-class drop object ;
+
+M: string-type c-type-boxed-class drop object ;
+
+M: string-type heap-size drop void* heap-size ;
+
+M: string-type c-type-align drop void* c-type-align ;
+
+M: string-type c-type-align-first drop void* c-type-align-first ;
+
+M: string-type base-type drop void* base-type ;
+
+M: string-type c-type-rep drop int-rep ;
+
+M: string-type c-type-boxer-quot
+    second dup binary =
+    [ drop void* c-type-boxer-quot ]
+    [ '[ _ alien>string ] ] if ;
+
+M: string-type c-type-unboxer-quot
+    second dup binary =
+    [ drop void* c-type-unboxer-quot ]
+    [ '[ _ string>alien ] ] if ;
+
+M: string-type c-type-getter
+    drop [ alien-cell ] ;
+
+M: string-type c-type-copier
+    drop [ ] ;
+
+M: string-type c-type-setter
+    drop [ set-alien-cell ] ;
+
+[ { c-string utf8 } c-string typedef ] with-compilation-unit

basis/alien/arrays/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/alien/arrays/summary.txt

@@ -0,0 +1 @@
+C array support

basis/alien/c-types/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/alien/c-types/c-types-docs.factor

@@ -0,0 +1,184 @@
+USING: alien help.syntax help.markup libc kernel.private
+byte-arrays strings hashtables alien.syntax alien.strings
+sequences io.encodings.string debugger destructors vocabs.loader
+classes.struct math kernel ;
+IN: alien.c-types
+
+HELP: heap-size
+{ $values { "name" c-type-name } { "size" math:integer } }
+{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
+{ $examples
+    { $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
+}
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
+
+HELP: <c-type>
+{ $values { "c-type" c-type } }
+{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
+
+HELP: no-c-type
+{ $values { "name" c-type-name } }
+{ $description "Throws a " { $link no-c-type } " error." }
+{ $error-description "Thrown by " { $link c-type } " if a given word is not a C type." } ;
+
+HELP: lookup-c-type
+{ $values { "name" c-type-name } { "c-type" c-type } }
+{ $description "Looks up a C type by name." }
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
+
+HELP: alien-value
+{ $values { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } { "value" object } }
+{ $description "Loads a value at a byte offset from a base C pointer." }
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
+
+HELP: set-alien-value
+{ $values { "value" object } { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } }
+{ $description "Stores a value at a byte offset from a base C pointer." }
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
+
+HELP: char
+{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
+HELP: uchar
+{ $description "This C type represents a one-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
+HELP: short
+{ $description "This C type represents a two-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
+HELP: ushort
+{ $description "This C type represents a two-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
+HELP: int
+{ $description "This C type represents a four-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: uint
+{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: long
+{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: intptr_t
+{ $description "This C type represents a signed integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: ulong
+{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: uintptr_t
+{ $description "This C type represents an unsigned integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: ptrdiff_t
+{ $description "This C type represents a signed integer type large enough to hold the distance between two pointer values; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: size_t
+{ $description "This C type represents unsigned size values of the size expected by the platform's standard C library (usually four bytes on a 32-bit platform, and eight on a 64-bit platform). Input values will be converted to " { $link math:integer } "s and truncated to the appropriate size; output values will be returned as " { $link math:integer } "s." } ;
+HELP: longlong
+{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: ulonglong
+{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: void
+{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
+HELP: void*
+{ $description "This C type represents a generic pointer to C memory. See " { $link pointer } " for information on pointer C types." } ;
+HELP: c-string
+{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
+HELP: float
+{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ;
+HELP: double
+{ $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ;
+
+HELP: pointer:
+{ $syntax "pointer: c-type" }
+{ $description "Constructs a " { $link pointer } " C type." } ;
+
+HELP: pointer
+{ $class-description "Represents a pointer C type. The " { $snippet "to" } " slot contains the C type being pointed to. Both " { $link byte-array } " and " { $link alien } " values can be provided as pointer function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Objects with methods on " { $link >c-ptr } ", such as structs and specialized arrays, may also be used as pointer inputs."
+$nl
+"Pointer output values are represented in Factor as " { $link alien } "s. If the pointed-to type is a struct, the alien will automatically be wrapped in a struct object if it is not null."
+$nl
+"In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, pointer types can be created by suffixing " { $snippet "*" } " to a C type name. Outside of FFI definitions, a pointer C type can be created using the " { $link POSTPONE: pointer: } " syntax word:"
+{ $unchecked-example "FUNCTION: int* foo ( char* bar ) ;" }
+{ $unchecked-example ": foo ( bar -- int* )
+    pointer: int f \"foo\" { pointer: char } f alien-invoke ;" } } ;
+
+ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
+"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
+$nl
+"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
+{ $list
+    "the C function returns"
+    "the C function calls Factor code via a callback"
+}
+"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
+$nl
+"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
+{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
+
+ARTICLE: "c-types.primitives" "Primitive C types"
+"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
+{ $table
+    { { $strong "C type" } { $strong "Notes" } }
+    { { $link char } "always 1 byte" }
+    { { $link uchar } { } }
+    { { $link short } "always 2 bytes" }
+    { { $link ushort } { } }
+    { { $link int } "always 4 bytes" }
+    { { $link uint } { } }
+    { { $link long } { "same size as CPU word size and " { $link void* } ", except on 64-bit Windows, where it is 4 bytes" } }
+    { { $link ulong } { } }
+    { { $link longlong } "always 8 bytes" }
+    { { $link ulonglong } { } }
+    { { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
+    { { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
+}
+"C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary."
+$nl
+"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
+
+ARTICLE: "c-types.pointers" "Pointer and array types"
+"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. This syntax constructs a " { $link pointer } " object to represent the C type."
+$nl
+"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
+{ $code "int[3][4]" }
+"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however, when used as function parameters, they behave exactly like pointers with the dimensions only serving as documentation." ;
+
+ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
+"Note that some of the C type word names clash with commonly-used Factor words:"
+{ $list
+  { { $link short } " clashes with the " { $link sequences:short } " word in the " { $vocab-link "sequences" } " vocabulary" }
+  { { $link float } " clashes with the " { $link math:float } " word in the " { $vocab-link "math" } " vocabulary" }
+}
+"If you use the wrong vocabulary, you will see a " { $link no-c-type } " error. For example, the following is " { $strong "not" } " valid, and will raise an error because the " { $link math:float } " word from the " { $vocab-link "math" } " vocabulary is not a C type:"
+{ $code
+  "USING: alien.syntax math prettyprint ;"
+  "FUNCTION: float magic_number ( ) ;"
+  "magic_number 3.0 + ."
+}
+"The following won't work either; now the problem is that there are two vocabularies in the search path that define a word named " { $snippet "float" } ":"
+{ $code
+  "USING: alien.c-types alien.syntax math prettyprint ;"
+  "FUNCTION: float magic_number ( ) ;"
+  "magic_number 3.0 + ."
+}
+"The correct solution is to use one of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } " to disambiguate word lookup:"
+{ $code
+  "USING: alien.syntax math prettyprint ;"
+  "QUALIFIED-WITH: alien.c-types c"
+  "FUNCTION: c:float magic_number ( ) ;"
+  "magic_number 3.0 + ."
+}
+"See " { $link "word-search-semantics" } " for details." ;
+
+ARTICLE: "c-types.structs" "Struct and union types"
+"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
+
+ARTICLE: "c-types-specs" "C type specifiers"
+"C types are identified by special words. Type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
+$nl
+"Defining new C types:"
+{ $subsections
+    POSTPONE: STRUCT:
+    POSTPONE: UNION-STRUCT:
+    POSTPONE: CALLBACK:
+    POSTPONE: TYPEDEF:
+}
+"Getting the c-type of a class:"
+{ $subsections lookup-c-type }
+{ $heading "Related articles" }
+{ $subsections
+    "c-types.primitives"
+    "c-types.pointers"
+    "c-types.ambiguity"
+    "c-types.structs"
+}
+;
+
+ABOUT: "c-types-specs"