This commit modifies build.sh to make a Skov.app instead of Factor.app while under development.
ifdef CONFIG
VERSION = 0.99
GIT_LABEL = $(shell echo `git describe --all`-`git rev-parse HEAD`)
- BUNDLE = Factor.app
+ BUNDLE = Skov.app
DEBUG ?= 0
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)
+ ENGINE = $(DLL_PREFIX)skov$(DLL_SUFFIX)$(DLL_EXTENSION)
+ EXECUTABLE = skov$(EXE_SUFFIX)$(EXE_EXTENSION)
+ CONSOLE_EXECUTABLE = skov$(EXE_SUFFIX)$(CONSOLE_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/aging_collector.o \
@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
+ALL = skov factor-ffi-test factor-lib
freebsd-x86-32:
$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32
ifdef CONFIG
-macosx.app: factor
+macosx.app: skov
mkdir -p $(BUNDLE)/Contents/MacOS
mkdir -p $(BUNDLE)/Contents/Frameworks
- mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
- ln -s $(BUNDLE)/Contents/MacOS/factor ./factor
+ mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/skov
+ ln -s $(BUNDLE)/Contents/MacOS/skov ./skov
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
factor-lib: $(ENGINE)
-factor: $(EXE_OBJS) $(DLL_OBJS)
+skov: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CXX) -L. $(DLL_OBJS) \
$(CFLAGS) $(CXXFLAGS) -o $(EXECUTABLE) $(LIBS) $(EXE_OBJS)
rm -f factor.dll.lib
rm -f libfactor.*
rm -f libfactor-ffi-test.*
- rm -f Factor.app/Contents/Frameworks/libfactor.dylib
+ rm -f Skov.app/Contents/Frameworks/libfactor.dylib
-.PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app
+.PHONY: skov factor-lib factor-console factor-ffi-test tags clean macosx.app
.PHONY: linux-x86-32 linux-x86-64 linux-ppc-32 linux-ppc-64 linux-arm-64 freebsd-x86-32 freebsd-x86-64 macosx-x86-32 macosx-x86-64 macosx-x86-fat macosx-arm64 windows-x86-32 windows-x86-64
* Unix: `./build.sh update`
* Windows: `build.cmd`
+* macOS: `./build.sh update`
* M1 macOS: `arch -x86_64 ./build.sh update`
or download the correct boot image for your system from
in `cpu.arm.assembler` and we are working on a port and also looking for
contributors.
+### Xcode
+Checkout the `xcode` branch and open the **Xcode/Factor.xcodeproj** project to build and run the engine from Xcode debugger.
+
More information on [building factor](https://concatenative.org/wiki/view/Factor/Building%20Factor)
and [system requirements](https://concatenative.org/wiki/view/Factor/Requirements).
--- /dev/null
+<?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>CFBundleDocumentTypes</key>
+ <array>
+ <dict>
+ <key>CFBundleTypeExtensions</key>
+ <array>
+ <string>*</string>
+ </array>
+ <key>CFBundleTypeName</key>
+ <string>Any</string>
+ <key>CFBundleTypeOSTypes</key>
+ <array>
+ <string>****</string>
+ </array>
+ <key>CFBundleTypeRole</key>
+ <string>Viewer</string>
+ </dict>
+ </array>
+ <key>CFBundleExecutable</key>
+ <string>skov</string>
+ <key>CFBundleIconFile</key>
+ <string>Skov.icns</string>
+ <key>ATSApplicationFontsPath</key>
+ <string>Fonts</string>
+ <key>CFBundleIdentifier</key>
+ <string>org.factorcode.Factor</string>
+ <key>CFBundleInfoDictionaryVersion</key>
+ <string>6.0</string>
+ <key>CFBundleName</key>
+ <string>Skov</string>
+ <key>CFBundlePackageType</key>
+ <string>APPL</string>
+ <key>CFBundleVersion</key>
+ <string>0.99</string>
+ <key>NSHumanReadableCopyright</key>
+ <string>Copyright © 2003-2020 Factor and Skov developers</string>
+ <key>NSServices</key>
+ <array>
+ <dict>
+ <key>NSMenuItem</key>
+ <dict>
+ <key>default</key>
+ <string>Factor/Evaluate in Listener</string>
+ </dict>
+ <key>NSMessage</key>
+ <string>evalInListener</string>
+ <key>NSPortName</key>
+ <string>Skov</string>
+ <key>NSSendTypes</key>
+ <array>
+ <string>NSStringPboardType</string>
+ </array>
+ </dict>
+ <dict>
+ <key>NSMenuItem</key>
+ <dict>
+ <key>default</key>
+ <string>Factor/Evaluate Selection</string>
+ </dict>
+ <key>NSMessage</key>
+ <string>evalToString</string>
+ <key>NSPortName</key>
+ <string>Skov</string>
+ <key>NSReturnTypes</key>
+ <array>
+ <string>NSStringPboardType</string>
+ </array>
+ <key>NSSendTypes</key>
+ <array>
+ <string>NSStringPboardType</string>
+ </array>
+ </dict>
+ </array>
+ <key>NSHighResolutionCapable</key>
+ <true/>
+ <key>UTExportedTypeDeclarations</key>
+ <array>
+ <dict>
+ <key>UTTypeIdentifier</key>
+ <string>public.source-factor</string>
+ <key>UTTypeReferenceURL</key>
+ <string>http://factorcode.org</string>
+ <key>UTTypeDescription</key>
+ <string>Factor Code</string>
+ <key>UTTypeIconFile</key>
+ <string>Skov.icns</string>
+ <key>ATSApplicationFontsPath</key>
+ <string>Fonts</string>
+ <key>UTTypeConformsTo</key>
+ <array>
+ <string>public.source</string>
+ <string>public.plain-text</string>
+ <string>public.text</string>
+ <string>public.data</string>
+ </array>
+ <key>UTTypeTagSpecification</key>
+ <dict>
+ <key>public.filename-extension</key>
+ <array>
+ <string>.factor</string>
+ </array>
+ </dict>
+ </dict>
+ </array>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<document type="com.apple.InterfaceBuilder3.Cocoa.XIB" version="3.0" toolsVersion="17156" targetRuntime="MacOSX.Cocoa" propertyAccessControl="none" useAutolayout="YES">
+ <dependencies>
+ <deployment version="1050" identifier="macosx"/>
+ <plugIn identifier="com.apple.InterfaceBuilder.CocoaPlugin" version="17156"/>
+ </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>
+ <menuItem title="Base16" id="c5Z-R4-x0d">
+ <modifierMask key="keyEquivalentModifierMask"/>
+ <connections>
+ <action selector="switchBase16Theme:" target="-1" id="ilJ-8c-q12"/>
+ </connections>
+ </menuItem>
+ <menuItem title="Wombat" id="5Ri-3D-AWg">
+ <modifierMask key="keyEquivalentModifierMask"/>
+ <connections>
+ <action selector="switchWombatTheme:" target="-1" id="BQz-Hk-EpG"/>
+ </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>
+ <point key="canvasLocation" x="-52" y="128"/>
+ </menu>
+ </objects>
+</document>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+USING: classes kernel parser words ;
+IN: classes.parser
+
+: create-class ( string vocab -- word )
+ create-word dup t "defining-class" set-word-prop
+ dup set-last-word
+ dup create-predicate-word drop ;
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes combinators
+combinators.short-circuit combinators.smart compiler.units
+effects fry hashtables.private kernel listener locals math
+math.order math.parser namespaces prettyprint sequences sorting
+sequences.deep sequences.extras sets splitting strings
+ui.gadgets vectors vocabs.parser definitions ;
+QUALIFIED: vocabs
+QUALIFIED: words
+IN: code
+
+TUPLE: element < identity-tuple name parent contents default-name target ;
+
+TUPLE: vocab < element ;
+TUPLE: word < element defined? result ;
+
+TUPLE: node < element quoted? ;
+TUPLE: introduce < node id ;
+TUPLE: return < node ;
+TUPLE: call < node completion ;
+TUPLE: text < node ;
+TUPLE: setter < node id ;
+TUPLE: getter < node id ;
+
+TUPLE: result < element ;
+
+UNION: input/output introduce return ;
+UNION: link setter getter ;
+UNION: source introduce text getter ;
+UNION: sink return setter ;
+
+PREDICATE: quoted-node < node quoted?>> ;
+
+SYMBOL: skov-root
+vocab new "●" >>name skov-root set-global
+
+SYMBOL: left
+SYMBOL: right
+
+: arity ( node -- n )
+ ! returns the number of children of a node
+ contents>> length ;
+
+: walk ( node -- seq )
+ [ contents>> [ walk ] map ] [ ] bi 2array ;
+
+: sort-tree ( word -- seq )
+ contents>> [ walk ] map flatten ;
+
+: vocabs ( elt -- seq ) contents>> [ vocab? ] filter ;
+: words ( elt -- seq ) contents>> [ word? ] filter ;
+: calls ( elt -- seq ) sort-tree [ call? ] filter ;
+: introduces ( elt -- seq ) sort-tree [ introduce? ] filter ;
+: returns ( elt -- seq ) contents>> [ return? ] filter ;
+: links ( elt -- seq ) sort-tree [ link? ] filter ;
+
+: own-introduces ( elt -- seq )
+ ! returns all "introduce" nodes in the child tree but ignores quoted nodes
+ contents>> [ [ introduce? ] filter ]
+ [ [ quoted?>> ] reject [ own-introduces ] map-concat ] bi
+ append ;
+
+:: add-element ( elt child-elt -- elt )
+ ! sets an existing element as the child of another existing element
+ child-elt elt >>parent elt [ ?push ] change-contents ;
+
+: add-from-class ( elt child-class -- elt )
+ ! sets a new element of a certain class as the child of an existing element
+ new add-element ;
+
+: add-with-name ( elt child-name child-class -- elt )
+ ! sets a new element of a certain class and with a certain name
+ ! as the child of an existing element
+ new swap >>name add-element ;
+
+: ?forget ( elt -- elt )
+ ! removes the corresponding Factor vocabulary or word
+ dup target>> [ [ forget ] with-compilation-unit ] when* ;
+
+:: remove-element ( elt -- parent )
+ ! removes a node from its parent
+ elt ?forget parent>> [ elt swap remove-eq ] change-contents ;
+
+: replace* ( seq old rep -- seq )
+ ! replaces an element with another element in a sequence
+ [ 1array ] bi@ replace ;
+
+:: replace-element ( old rep -- rep )
+ ! replaces an element with another element
+ old parent>> [ old rep old parent>> >>parent replace* ] change-contents drop rep ;
+
+: replace-parent ( node -- node )
+ ! replaces the parent of the node with the node
+ dup parent>> [ node? ] [ swap replace-element ] smart-when* ;
+
+: insert-new-parent ( old -- new )
+ ! replaces an element with a new element of a certain class
+ ! and sets the old element as a child of the new one
+ dup call new replace-element swap add-element ;
+
+:: exchange-node-side ( node side -- node )
+ ! exchanges a node and the node the left/right
+ node parent>> [ vocab? ] [ [ [ class-of ] sort-with ] change-contents ] smart-when
+ contents>> :> nodes
+ node nodes index dup side left eq? -1 1 ? +
+ nodes length 1 - min 0 max nodes exchange node ;
+
+: top-node? ( node -- ? )
+ ! tells if the node has no children
+ contents>> empty? ;
+
+: bottom-node? ( node -- ? )
+ ! tells if the node has no parent
+ parent>> node? not ;
+
+: leftmost-node? ( node -- ? )
+ ! tells if a node has no brother on the left
+ dup parent>> contents>> index 0 = ;
+
+: rightmost-node? ( node -- ? )
+ ! tells if a node has no brother on the right
+ dup parent>> contents>> [ index ] keep length 1 - = ;
+
+: middle-node? ( node -- ? )
+ ! tells if a node has a parent and has children
+ [ top-node? ] [ bottom-node? ] bi or not ;
+
+: parent-node ( node -- node )
+ ! returns the parent of the node, or the same node if the parent is a "word"
+ [ parent>> dup word? not and ] [ parent>> ] smart-when ;
+
+: child-node ( node -- node )
+ ! returns the first child of the node, or the same node if it has no children
+ [ contents>> empty? ] [ contents>> first ] smart-unless ;
+
+:: side-node ( node side -- node )
+ ! returns the brother node on the left/right,
+ ! or the same node if there is nothing to the left/right
+ node parent>> contents>> :> nodes
+ node nodes index 1 side left eq? [ - ] [ + ] if nodes ?nth [ node ] unless* ;
+
+:: change-nodes-above ( elt names -- )
+ elt arity :> old-n
+ names length :> n
+ elt {
+ { [ n old-n > ] [ n old-n - [ call add-from-class ] times drop ] }
+! { [ n old-n < ] [ contents>> n swap shorten ] }
+ [ drop ]
+ } cond
+ names elt contents>> [ default-name<< ] 2each ;
+
+:: change-node-type ( node class -- new-node )
+ ! replaces a node by a node of a different type that has the same name and contents
+ node class new node name>> >>name node quoted?>> >>quoted?
+ node contents>> [ add-element ] each replace-element ;
+
+: no-return? ( node -- ? )
+ ! tells if the word that contains the node has no "return" child
+ [ word? ] find-parent returns empty? ;
+
+: ?change-node-type ( node class -- new-node )
+ ! replaces a node by a node of a different type that has the same name and contents
+ ! only if certain conditions are met
+ 2dup {
+ { introduce [ top-node? ] }
+ { text [ top-node? ] }
+ { getter [ top-node? ] }
+ { return [ [ bottom-node? ] [ no-return? ] bi and ] }
+ { setter [ bottom-node? ] }
+ [ drop drop t ]
+ } case [ change-node-type ] [ drop ] if ;
+
+: name-or-default ( elt -- str )
+ ! returns the name of the element, or its default name, or its class
+ { { [ dup name>> empty? not ] [ name>> ] }
+ { [ dup default-name>> empty? not ] [ default-name>> ] }
+ { [ dup introduce? ] [ drop "input" ] }
+ { [ dup return? ] [ drop "output" ] }
+ { [ dup call? ] [ drop "word" ] }
+ { [ dup vocab? ] [ drop "vocabulary" ] }
+ { [ dup getter? ] [ drop "get" ] }
+ { [ dup setter? ] [ drop "set" ] }
+ [ class-of unparse ] } cond >string ;
+
+CONSTANT: special-words { "while" "until" "if" "times" "produce" }
+GENERIC: factor-name ( elt -- str )
+
+M: element factor-name
+ name>> ;
+
+M: call factor-name
+ name>> dup special-words member? [ "special " prepend ] when ;
+
+GENERIC: path ( elt -- str )
+
+M: vocab path
+ parents reverse rest [ factor-name ] map "." join [ "scratchpad" ] when-empty ;
+
+M: word path
+ parents reverse rest but-last [ factor-name ] map "." join [ "scratchpad" ] when-empty ;
+
+M: call path
+ target>> [ words:word? ] [ vocabulary>> ] [ drop f ] smart-if ;
+
+M: node path
+ drop f ;
+
+: replace-quot ( seq -- seq )
+ [ array? ] [ first [ "quot" swap subseq? not ] [ " quot" append ] smart-when ] smart-when ;
+
+: convert-stack-effect ( stack-effect -- seq seq )
+ ! converts a stack effect into two sequences of input and output names
+ [ in>> ] [ out>> ] bi [ [ replace-quot ] map ] bi@ ;
+
+: same-name-as-parent? ( call -- ? )
+ ! tells if a call has the same name as its parent
+ dup [ word? ] find-parent [ name>> ] bi@ = ;
+
+: input-output-names ( word -- seq seq )
+ ! returns two sequences containing the input and output names of a word
+ [ introduces ] [ returns ] bi [ [ name>> ] map sift members ] bi@ ;
+
+SINGLETON: recursion
+
+GENERIC: (in-out) ( elt -- seq seq )
+
+M: source (in-out)
+ drop f { "" } ;
+
+M: sink (in-out)
+ drop { "" } f ;
+
+M:: call (in-out) ( call -- seq seq )
+ call target>>
+ { { [ dup recursion? ] [ drop call [ word? ] find-parent input-output-names ] }
+ { [ dup number? ] [ drop { } { "" } ] }
+ { [ dup not ] [ drop { } { } ] }
+ [ "declared-effect" words:word-prop convert-stack-effect ]
+ } cond ;
+
+CONSTANT: sequence-variadic-words { "array" } ! "sequence" "each" "map" "append" "produce" }
+CONSTANT: special-variadic-words { "call" }
+
+: simple-variadic? ( call -- ? )
+ (in-out) { [ drop length 2 = ] [ nip length 1 = ]
+ [ first swap first2 dupd = -rot = and ] } 2&& ;
+
+: comparison-variadic? ( call -- ? )
+ (in-out) [ length 2 = ] [ ?first "?" = ] bi* and ;
+
+: sequence-variadic? ( call -- ? )
+ name>> sequence-variadic-words member? ;
+
+: special-variadic? ( call -- ? )
+ name>> special-variadic-words member? ;
+
+: variadic? ( call -- ? )
+ { [ simple-variadic? ] [ comparison-variadic? ]
+ [ sequence-variadic? ] [ special-variadic? ] } cleave or or or ;
+
+:: insert-node-side ( node side -- new-node )
+ ! inserts a new "call" to the left/right of a node
+ node dup parent>> { [ word? ] [ variadic? ] } 1||
+ [ parent>> contents>> :> nodes
+ call new node parent>> >>parent dup :> new-node
+ node nodes index side right eq? [ 1 + ] when
+ nodes insert-nth! new-node ] when ;
+
+:: in-out ( elt -- seq seq )
+ { { [ elt call? not ] [ elt (in-out) ] }
+ { [ elt simple-variadic? ]
+ [ elt (in-out) [ first [ ] curry elt arity 2 max swap replicate ] dip ] }
+ { [ elt sequence-variadic? ]
+ [ elt arity 1 max [ "x" ] replicate { "seq" } ] }
+ { [ elt name>> "call" = ]
+ [ f elt arity 1 - [ "x" suffix ] times "quot" suffix { "result" } ] }
+ [ elt (in-out) ]
+ } cond ;
+
+: short-name ( str -- str )
+ " (constructor)" " (accessor)" " (mutator)" [ "" replace ] tri@ ;
+
+:: matching-words ( str -- seq )
+ ! returns all Factor words whose name begins with a certain string
+ interactive-vocabs get [ vocabs:vocab-words ] map concat [ name>> str head? ] filter ;
+
+:: matching-words-exact ( str -- seq )
+ ! returns all Factor words that have a certain name
+ interactive-vocabs get [ vocabs:vocab-words ] map concat [ name>> short-name str = ] filter ;
+
+:: find-target ( call -- seq )
+ ! returns the Factor word that has the same name as the call
+ call factor-name :> name
+ { { [ call same-name-as-parent? ] [ recursion 1array ] }
+ { [ name string>number ] [ name string>number 1array ] }
+ [ name matching-words-exact ]
+ } cond ;
+
+: (un)quote ( node -- node )
+ ! toggles the "quoted?" attribute of a node
+ [ not ] change-quoted? ;
+
+:: ?add-words-above ( elt -- )
+ elt elt in-out drop change-nodes-above
+ elt contents>> [ ?add-words-above ] each ;
+
+:: ?add-word-below ( elt -- )
+ elt in-out nip [ first elt insert-new-parent default-name<< ] unless-empty ;
+
+:: ?add-words ( word -- word )
+ word contents>>
+ [ word call add-from-class drop ]
+ [ [ dup ?add-word-below ?add-words-above ] each ]
+ if-empty word ;
+
+: any-empty-name? ( word -- ? )
+ ! tells if there are any empty names in the child tree of a word
+ sort-tree
+ [ [ introduce? ] [ [ quoted-node? ] find-parent ] bi and ] reject
+ [ name>> empty? ] any? ;
+
+: executable? ( word -- ? )
+ ! tells if a word has the right properties to be executable
+ { [ word? ]
+ [ introduces [ [ quoted-node? ] find-parent ] reject empty? ]
+ [ returns empty? ]
+ [ calls empty? not ]
+ [ any-empty-name? not ]
+ [ defined?>> ]
+ } 1&& ;
+
+: error? ( word -- ? )
+ ! tells if a word contains any error
+ { [ defined?>> not ]
+ [ any-empty-name? ]
+ [ contents>> empty? ]
+ } 1|| ;
+
+: save-result ( str word -- )
+ ! stores a string as the result of a word
+ swap dupd result new swap >>contents swap >>parent >>result drop ;
--- /dev/null
+! Copyright (C) 2015-2016 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes.parser classes.tuple code
+combinators combinators.smart compiler.units debugger effects io
+io.streams.string kernel listener locals locals.rewrite
+locals.types math math.statistics namespaces quotations
+sequences sequences.deep sets splitting ui.gadgets.panes
+vocabs.parser ;
+FROM: code => call ;
+QUALIFIED: words
+QUALIFIED: vocabs
+IN: code.execution
+
+: effect ( def -- effect )
+ [ introduces [ name>> empty? ] reject ] [ returns ] bi
+ [ [ factor-name ] map members >array ] bi@ <effect> ;
+
+: set-ids ( seq -- )
+ [ name>> ] collect-by [
+ [ drop empty? ]
+ [ [ "x" <local> >>id ] map 2drop ]
+ [ [ <local> ] dip [ id<< ] with each ] smart-if
+ ] assoc-each ;
+
+: set-input-ids ( word -- word )
+ dup introduces set-ids ;
+
+: set-link-ids ( word -- word )
+ dup links set-ids ;
+
+:: process-simple-variadic ( call -- seq )
+ call arity 1 - [ call target>> ] replicate ;
+
+:: process-comparison-variadic ( call -- seq )
+ call arity 2 = [ call target>> 1array ]
+ [ \ dupd call target>> \ -rot 3array
+ call arity 3 -
+ [ \ dupd suffix call target>> suffix \ swapd suffix \ and suffix \ -rot suffix ] times
+ call target>> suffix \ and suffix ] if ;
+
+:: process-sequence-variadic ( call -- seq )
+ call arity
+ call name>> "1" ?head drop CHAR: n prefix [ search ] with-interactive-vocabs
+ 2array ;
+
+: process-quotation-call ( call -- seq )
+ arity 1 - [ "x" ] replicate "o" 1array <effect> \ call-effect 2array ;
+
+: process-variadic ( call -- word/seq )
+ { { [ dup name>> "call" = ] [ process-quotation-call ] }
+ { [ dup simple-variadic? ] [ process-simple-variadic ] }
+ { [ dup comparison-variadic? ] [ process-comparison-variadic ] }
+ { [ dup sequence-variadic? ] [ process-sequence-variadic ] }
+ [ target>> ]
+ } cond ;
+
+GENERIC: transform ( node -- compiler-node )
+
+:: transform-quotation ( node -- compiler-node )
+ node transform node quoted-node?
+ [ node own-introduces [ name>> empty? ] filter [ transform ] map
+ swap flatten >quotation <lambda> ] when ;
+
+M: introduce transform
+ id>> ;
+
+M: text transform
+ name>> ;
+
+M: getter transform
+ id>> ;
+
+M: setter transform
+ [ contents>> [ transform-quotation ] map ] [ id>> <def> ] bi 2array ;
+
+M: call transform
+ [ contents>> [ transform-quotation ] map ] [ process-variadic ] bi 2array ;
+
+M: return transform
+ contents>> [ transform-quotation ] map ;
+
+M: word transform
+ set-input-ids set-link-ids
+ [ introduces [ name>> empty? ] reject [ transform ] map members ]
+ [ contents>> [ transform-quotation ] map flatten >quotation ] bi <lambda> ;
+
+:: set-recursion ( word lambda -- lambda )
+ lambda [ recursion 1array word 1array replace
+ dup [ lambda? ] filter [ word swap set-recursion ] map drop ] change-body ;
+
+:: try-definition ( quot def -- )
+ [ def f >>defined? quot with-compilation-unit t >>defined? drop ] try ; inline
+
+: interactive? ( vocab-name -- ? )
+ interactive-vocabs get-global member? ;
+
+: add-interactive-vocab ( vocab-name -- )
+ [ interactive? not ]
+ [ interactive-vocabs [ swap suffix ] change-global ] smart-when* ;
+
+: remove-interactive-vocab ( vocab-name -- )
+ interactive-vocabs [ remove ] change-global ;
+
+GENERIC: define ( def -- )
+
+M:: vocab define ( def -- )
+ def path [ vocabs:create-vocab def target<< ] [ add-interactive-vocab ] bi ;
+
+M:: word define ( def -- )
+ [ def factor-name
+ def path words:create-word dup dup def target<<
+ def transform set-recursion rewrite-closures first
+ def effect words:define-declared
+ ] def try-definition ;
+
+: ?define ( elt -- )
+ [ name>> ] [ define ] smart-when* ;
+
+: run-word ( word -- )
+ [ ?define ]
+ [ target>> f pane new-pane dup swapd <pane-stream> [ execute( -- ) ] with-output-stream ]
+ [ save-result ] tri ;
--- /dev/null
+! Copyright (C) 2016-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors code combinators combinators.smart effects
+kernel locals math math.parser quotations sequences splitting
+stack-checker strings vectors words ;
+FROM: code => call word ;
+IN: code.factor-abstraction
+
+:: call-from-factor ( factor-word -- call )
+ call new factor-word name>> >>name factor-word >>target ;
+
+: make-tree ( nodes -- tree )
+ dup [ introduce new ] [ pop ] if-empty dup
+ [ quoted-node? ] [ drop 0 ] [ in-out drop length ] smart-if
+ swapd [ dup make-tree ] replicate reverse nip [ add-element ] each ;
+
+: node-from-factor ( factor-word -- node )
+ { { [ dup words:word? ] [ call-from-factor ] }
+ { [ dup string? ] [ text new >>name ] }
+ { [ dup number? ] [ call new swap [ number>string >>name ] keep >>target ] }
+ { [ dup quotation? ] [ [ node-from-factor ] map >vector make-tree t >>quoted? ] }
+ } cond ;
+
+:: word-from-factor ( factor-word -- word )
+ factor-word stack-effect
+ [ in>> [ introduce new swap >>name ] map ]
+ [ out>> [ return new swap >>name ] map ] bi
+ factor-word def>> [ node-from-factor ] map
+ swap 3append >vector make-tree
+ word new swap add-element ;
--- /dev/null
+! Copyright (C) 2016 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes combinators combinators.smart
+eval io io.directories io.encodings.utf8 io.files io.files.info
+io.pathnames kernel locals math namespaces prettyprint prettyprint.config
+sequences code system ui.gadgets code.execution ;
+FROM: code => call ;
+IN: code.import-export
+
+SYMBOL: skov-version
+
+: work-directory ( -- path )
+ image-path parent-directory "work" append-path ;
+
+: make-directory? ( path -- path )
+ [ file-exists? not ] [ dup make-directory ] smart-when ;
+
+: vocab-directory-path ( elt -- str )
+ parents reverse rest [ factor-name ] map path-separator join work-directory swap append-path ;
+
+GENERIC: (export) ( element -- seq )
+
+: export ( element -- seq )
+ [ (export) ] [ name>> prefix ] [ class-of prefix ] tri ;
+
+M: element (export)
+ contents>> [ export ] map >array 1array ;
+
+M: vocab (export)
+ words [ export ] map >array 1array ;
+
+M: node (export)
+ [ quoted?>> ] [ contents>> [ export ] map >array ] bi 2array ;
+
+M: call (export)
+ [ path ] [ quoted?>> ] [ contents>> [ export ] map >array ] tri 3array ;
+
+:: write-vocab-file ( vocab -- )
+ vocab vocab-directory-path make-directory?
+ vocab factor-name ".skov" append append-path utf8
+ [ "! Skov version " skov-version get-global append print vocab export [ . ] without-limits ] with-file-writer
+ vocab vocabs [ write-vocab-file ] each ;
+
+: export-vocabs ( -- )
+ skov-root get-global write-vocab-file ;
+
+:: find-target-with-path ( call -- )
+ call target>> :> this-path
+ call dup find-target
+ [ [ number? not ] [ vocabulary>> this-path = ] [ t ] smart-if* ] filter
+ ?first >>target drop ;
+
+: find-targets ( def -- )
+ calls [ find-target-with-path ] each ;
+
+: define-all-words ( vocab -- )
+ [ ?define ]
+ [ vocabs [ define-all-words ] each ]
+ [ words [ [ find-targets ] [ ?define ] bi ] each ] tri ;
+
+GENERIC: (import) ( seq element -- element )
+
+: import ( seq -- element )
+ unclip new swap unclip swapd >>name (import) ;
+
+M: element (import)
+ swap first [ import add-element ] each ;
+
+M: node (import)
+ swap first2 [ >>quoted? ] [ [ import add-element ] each ] bi* ;
+
+M: call (import)
+ swap first3 [ >>target ] [ >>quoted? ] [ [ import add-element ] each ] tri* ;
+
+: sub-directories ( path -- seq )
+ dup directory-entries [ directory? ] filter [ name>> append-path ] with map ;
+
+: any-vocab-files? ( path -- ? )
+ directory-files [ file-extension "skov" = ] filter empty? not ;
+
+: skov-file ( path -- path )
+ dup directory-files [ file-extension "skov" = ] filter first append-path ;
+
+:: read-vocab-files ( path -- vocab )
+ path skov-file utf8 file-contents "USE: code " swap append eval( -- seq ) import
+ path sub-directories [ read-vocab-files add-element ] each ;
+
+: update-skov-root ( -- )
+ skov-root work-directory [ any-vocab-files? ]
+ [ read-vocab-files dup define-all-words swap set-global ] [ drop ] smart-if* ;
IN: fonts
CONSTANT: default-serif-font-name "serif"
-CONSTANT: default-sans-serif-font-name "sans-serif"
-CONSTANT: default-monospace-font-name "monospace"
+CONSTANT: default-sans-serif-font-name "Linux Biolinum O" inline
+CONSTANT: default-monospace-font-name "Linux Biolinum O" inline
-CONSTANT: default-font-size 12
+CONSTANT: default-font-size 15
SYMBOL: default-font-foreground-color
COLOR: black default-font-foreground-color set-global
TUPLE: selection string start end color ;
C: <selection> selection
+
HELP: $snippet
{ $values { "children" "markup elements" } }
-{ $description "Prints a key word or otherwise notable snippet of text, such as a type or a word input parameter. To document slot names, use " { $link $slot } "." } ;
+{ $description "Prints a key word or otherwise notable snippet of text, such as a type or a word input parameter. To document slot names, use " { $link $slot } "." }
+{ $examples
+ { $markup-example { $snippet "vocab" } }
+ { $markup-example { $snippet "{ string... }" } }
+} ;
HELP: $slot
{ $values { "children" "markup elements" } }
HELP: $values
{ $values { "element" "an array of pairs of markup elements" } }
{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is inserted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
-{ $see-also $maybe $instance $quotation } ;
+{ $see-also $maybe $instance $quotation }
+{ $examples
+ { $markup-example { $values { "arg1" "description of arg1" } { "arg2" integer } } }
+}
+$nl ;
HELP: $instance
{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
] { } map>assoc
] bi@ \ $inputs \ $outputs [ prefix ] bi-curry@ bi* 2array ;
-M: word word-help* stack-effect effect-help ;
+! M: word word-help* stack-effect effect-help ;
+
+! skov
+M: word word-help*
+ stack-effect [ in>> ] [ out>> ] bi [
+ [
+ dup pair? [
+ first2 dup effect? [ \ $quotation swap 2array ] when
+ ] [
+ object
+ ] if [ effect>string ] dip
+ ] { } map>assoc
+ ] bi@ [ \ $inputs prefix ] dip \ $outputs prefix 2array ;
: $predicate ( element -- )
{ { "object" object } { "?" boolean } } $values
M: word article-name name>> ;
+! M: word article-title
+! dup [ parsing-word? ] [ symbol? ] bi or [
+! name>>
+! ] [
+! [ unparse ]
+! [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
+! append
+! ] if ;
+
+! skov
M: word article-title
- dup [ parsing-word? ] [ symbol? ] bi or [
- name>>
- ] [
- [ unparse ]
- [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
- append
- ] if ;
+ dup [ parsing-word? ] [ symbol? ] bi or [ name>> ] [ unparse ] if ;
<PRIVATE
+! : (word-help) ( word -- element )
+! [
+! {
+! [ \ $vocabulary swap 2array , ]
+! [ word-help % ]
+! [ \ $related swap 2array , ]
+! [ dup global at [ get-global \ $value swap 2array , ] [ drop ] if ]
+! [ \ $definition swap 2array , ]
+! } cleave
+! ] { } make ;
+
+! skov
: (word-help) ( word -- element )
[
{
[ \ $vocabulary swap 2array , ]
+ [ \ $graph swap 2array , ]
[ word-help % ]
- [ \ $related swap 2array , ]
[ dup global at [ get-global \ $value swap 2array , ] [ drop ] if ]
[ \ $definition swap 2array , ]
+ [ \ $related swap 2array , ]
} cleave
] { } make ;
M: generic article-content word-with-methods ;
-M: class article-content word-with-methods ;
+! M: class article-content word-with-methods ;
+
+! skov
+M: class article-content (word-help) ;
M: word article-parent "help-parent" word-prop ;
io io.styles kernel make math namespaces present prettyprint
prettyprint.stylesheet quotations see sequences
sequences.private sets sorting splitting strings urls vocabs
-words words.symbol ;
+words words.symbol ;
FROM: prettyprint.sections => with-pprint ;
IN: help.markup
[ [ "None" write ] ($block) ]
[ [ values-row ] map $table ] if-empty ;
+! : $inputs ( element -- )
+! "Inputs" $heading ($values) ;
+
+! skov
: $inputs ( element -- )
- "Inputs" $heading ($values) ;
+ "Inputs" $heading
+ [ [ "none" print ] ($block) ]
+ [ [ values-row ] map $table ] if-empty ;
+! : $outputs ( element -- )
+! "Outputs" $heading ($values) ;
+
+! skov
: $outputs ( element -- )
- "Outputs" $heading ($values) ;
+ "Outputs" $heading
+ [ [ "none" print ] ($block) ]
+ [ [ values-row ] map $table ] if-empty ;
: $values ( element -- )
"Inputs and outputs" $heading ($values) ;
: $see ( element -- ) check-first [ see* ] ($see) ;
+! skov
+! : $see ( element -- )
+! check-first <definition-tree> nl output-stream get write-gadget ;
+
: $synopsis ( element -- ) check-first [ synopsis write ] ($see) ;
: $definition ( element -- )
[ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
{ f { $strong "Definition class" } } prefix
$table ;
+
+! skov
+DEFER: <help-tree>
+DEFER: write-gadget
+: $graph ( element -- )
+ check-first <help-tree> nl nl output-stream get write-gadget ;
+
: single-epsilon ( -- epsilon ) 0x34000000 bits>float ; foldable
: smallest-float ( -- x ) 0x1 bits>double ; foldable
: largest-float ( -- x ) 0x7fefffffffffffff bits>double ; foldable
+: tau ( -- tau ) 2 pi * ; inline
dup first Letter? [ rest ] unless
(command-name) ;
+! skov
+! M: word command-name
+! name>> "com " ?head drop "." ?tail drop
+! dup first Letter? [ rest ] unless
+! (command-name) ;
+
M: word command-description
+description+ word-prop ;
--- /dev/null
+! Copyright (C) 2016 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors code.execution combinators.smart help.topics
+kernel locals models ui.gadgets ui.gadgets.buttons.round
+ui.gadgets.packs ui.tools.environment.theme vocabs words ;
+IN: ui.gadgets.buttons.activate
+
+: vocab/word? ( obj -- ? )
+ [ vocab? ] [ [ link? ] [ name>> word? ] [ drop f ] smart-if ] bi or ;
+
+: vocab-name ( obj -- str )
+ name>> [ word? ] [ vocabulary>> ] smart-when ;
+
+:: <activate-button> ( model -- gadget )
+ model value>> vocab-name :> name
+ name interactive?
+ [ blue-background "Active"
+ [ drop name remove-interactive-vocab model notify-connections ]
+ <round-button> "Deactivate this vocabulary" >>tooltip ]
+ [ dark-background "Inactive"
+ [ drop name add-interactive-vocab model notify-connections ]
+ <round-button> "Activate this vocabulary" >>tooltip ] if ;
+
+TUPLE: active/inactive < pack ;
+
+: <active/inactive> ( model -- gadget )
+ active/inactive new swap >>model ;
+
+M: active/inactive model-changed
+ dup clear-gadget swap
+ [ value>> vocab/word? ] [ <activate-button> add-gadget ] smart-when* drop ;
--- /dev/null
+! Copyright (C) 2015 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors colors.gray kernel locals math
+math.order sequences ui.gadgets ui.gadgets.buttons combinators.smart
+ui.pens.gradient-rounded ui.tools.environment.theme ;
+IN: ui.gadgets.buttons.round
+
+TUPLE: round-button < button ;
+
+M: round-button pref-dim*
+ gadget-child [ text>> length 1 > ]
+ [ pref-dim first2 [ 15 + ] dip [ 20 max ] bi@ 2array ]
+ [ { 20 20 } ] smart-if* ;
+
+:: <round-button> ( colors label quot -- button )
+ label quot round-button new-button
+ colors dup first >gray gray>> 0.5 < light-text-colour dark-text-colour ?
+ <gradient-squircle> >>interior
+ dup gadget-child
+ [ t >>bold? 13 >>size transparent >>background ] change-font drop ;
--- /dev/null
+USING: accessors arrays assocs colors combinators
+combinators.short-circuit combinators.smart kernel locals math
+math.functions math.order math.ranges math.vectors opengl.gl
+sequences ui.gadgets ui.gadgets.packs ui.pens ui.pens.caching
+ui.pens.gradient system ;
+IN: ui.pens.gradient-rounded
+
+TUPLE: gradient-shape < caching-pen colors foreground shape last-vertices last-colors ;
+TUPLE: gradient-squircle < gradient-shape ;
+TUPLE: gradient-arrow < gradient-shape ;
+TUPLE: gradient-pointy < gradient-shape ;
+TUPLE: gradient-dynamic-shape < gradient-shape selected? ;
+
+: <gradient-squircle> ( colors foreground -- gradient )
+ gradient-squircle new swap >>foreground swap >>colors ;
+
+: <gradient-arrow> ( colors foreground -- gradient )
+ gradient-arrow new swap >>foreground swap >>colors ;
+
+: <gradient-pointy> ( colors foreground -- gradient )
+ gradient-pointy new swap >>foreground swap >>colors ;
+
+: <gradient-dynamic-shape> ( colors foreground selected? -- gradient )
+ gradient-dynamic-shape new swap >>selected? swap >>foreground swap >>colors ;
+
+<PRIVATE
+
+CONSTANT: tau 6.283185307179586
+CONSTANT: points 100
+
+: squircle-point ( theta -- xy )
+ [ cos ] [ sin ] bi [ [ abs sqrt ] [ sgn ] bi * 0.5 * 0.5 + ] bi@ 2array ;
+
+:: tan-point ( y slope -- xy )
+ y tau * 4 / tan 300 / 0.5 min y slope / + y 2array ;
+
+:: squircle ( -- seq )
+ 1/4 tau * 3/4 tau * 1/2 tau * points / <range> [ squircle-point ] map ;
+
+:: arrow ( -- seq )
+ { { -0.25 1 } { 0 0.5 } { -0.25 0 } } ;
+
+:: wide-narrow ( slope -- seq )
+ 0.0 1.0 1 points / <range> [ slope tan-point ] map reverse ;
+
+: narrow-wide ( slope -- seq )
+ wide-narrow unzip [ reverse ] dip zip ;
+
+:: wide-narrow-wide ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ min ] 2map ] dip zip ;
+
+:: narrow-wide-narrow ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ max ] 2map ] dip zip ;
+
+:: vertices ( dim left-shape right-shape symmetric? -- seq )
+ dim first2 :> ( x y )
+ left-shape right-shape [ call( -- seq ) [ y v*n ] map ] bi@
+ reverse symmetric? [ [ first2 [ neg ] dip 2array ] map ] unless
+ [ first2 swap x swap - swap 2array ] map append
+ x 2 / y 2 / 2array prefix dup second suffix ;
+
+:: interp-color ( x colors -- seq )
+ colors [ >rgba-components 4array ] map first2 zip [ first2 dupd - x * - ] map ;
+
+:: vertices-colors ( dim seq colors -- seq )
+ seq [ second dim second / colors interp-color ] map ;
+
+: draw-triangle-fan ( vertices colors -- )
+ GL_TRIANGLE_FAN glBegin
+ [ first3 glColor3f first2 glVertex2f ] 2each
+ glEnd ;
+
+:: gradient-start ( edge center -- s )
+ center first2 :> ( xc yc )
+ edge first2 :> ( xe ye )
+ 8 xe xc - sq ye yc - sq + sqrt / :> alpha
+ xe xe xc - alpha * -
+ ye ye yc - alpha * - 8 max 16 min 2array ;
+
+: draw-triangle-fan-selected ( vertices -- )
+ unclip dupd [ gradient-start ] curry map
+ GL_TRIANGLE_STRIP glBegin
+ [ 1.0 1.0 1.0 0.0 glColor4f first2 glVertex2f
+ 1.0 1.0 1.0 0.6 glColor4f first2 glVertex2f ] 2each
+ glEnd ;
+
+: left ( gadget -- dim ) screen-loc first ;
+: right ( gadget -- dim ) [ screen-loc first ] [ dim>> first ] bi + ;
+
+: default-value ( side -- x )
+ \ left = 10000 0 ? ;
+
+: compare ( x y side -- ? )
+ \ left = [ 3 - < ] [ 3 + > ] if ;
+
+:: above ( gadget side -- dim )
+ gadget parent>> gadget-child children>> [ empty? not ]
+ [ side \ left = [ first ] [ last ] if children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: below ( gadget side -- dim )
+ gadget parent>> parent>>
+ [ dup parent>> children>> { [ length 1 > nip ] [ second = not ] } 2&& ]
+ [ parent>> children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: above-wider? ( gadget side -- ? )
+ gadget [ side above ] [ side execute( x -- x ) ] bi side compare ;
+
+:: below-wider? ( gadget side -- ? )
+ gadget [ side below ] [ side execute( x -- x ) ] bi side compare ;
+
+:: find-half-shape ( gadget side -- shape ) {
+ { [ gadget left 10 < ] [ [ squircle ] ] }
+ { [ gadget side above-wider? gadget side below-wider? and ] [ [ 6 wide-narrow-wide ] ] }
+ { [ gadget side above-wider? gadget side below-wider? not and ] [ [ 6 wide-narrow ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? and ] [ [ 6 narrow-wide ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? not and ] [ [ 6 narrow-wide-narrow ] ] }
+ } cond ;
+
+: find-shape ( gadget -- left-shape right-shape )
+ [ \ left find-half-shape ] [ \ right find-half-shape ] bi ;
+
+:: (recompute-pen) ( gadget gradient left-shape right-shape symmetric? -- )
+ gadget dim>> dup left-shape right-shape symmetric? vertices dup gradient last-vertices<<
+ gradient colors>> vertices-colors gradient last-colors<< ;
+
+M: gradient-squircle recompute-pen ( gadget gradient -- )
+ [ squircle ] dup t (recompute-pen) ;
+
+M: gradient-arrow recompute-pen ( gadget gradient -- )
+ [ arrow ] dup f (recompute-pen) ;
+
+M: gradient-pointy recompute-pen ( gadget gradient -- )
+ [ 1.5 narrow-wide-narrow ] dup t (recompute-pen) ;
+
+M:: gradient-dynamic-shape recompute-pen ( gadget gradient -- )
+ gadget gradient gadget find-shape t (recompute-pen) ;
+
+PRIVATE>
+
+M: gradient-shape draw-interior
+ [ compute-pen ]
+ [ last-vertices>> ]
+ [ last-colors>> draw-triangle-fan ] tri ;
+
+M: gradient-shape pen-background
+ 2drop transparent ;
+
+M: gradient-shape pen-foreground
+ nip foreground>> ;
+
+M: gradient-dynamic-shape draw-interior
+ [ call-next-method ]
+ [ selected?>> ]
+ [ last-vertices>> ] tri
+ [ draw-triangle-fan-selected ] curry when ;
--- /dev/null
+USING: accessors colors kernel locals math opengl opengl.gl
+sequences ui.pens ui.tools.environment.theme system ;
+IN: ui.pens.title-gradient
+
+TUPLE: title-gradient colors foreground selected? ;
+
+: <title-gradient> ( colors foreground selected? -- gradient )
+ title-gradient new swap >>selected? swap >>foreground swap >>colors ;
+
+:: draw-gradient ( dim gradient -- )
+ GL_QUADS glBegin
+ gradient first >rgba-components glColor4f
+ 0.0 0.0 glVertex2f
+ dim first 0.0 glVertex2f
+ gradient second >rgba-components glColor4f
+ dim first2 glVertex2f
+ 0.0 dim second glVertex2f
+ glEnd ;
+
+:: draw-underline ( dim gradient -- )
+ 1 gl-scale glLineWidth
+ GL_LINES glBegin
+ gradient first >rgba-components glColor4f
+ 0.0 dim second glVertex2f
+ dim first2 glVertex2f
+ glEnd ;
+
+CONSTANT: shadow-width 20.0
+
+:: draw-shadows ( dim -- )
+ GL_QUADS glBegin
+ content-background-colour >rgba-components glColor4f
+ 0.0 0.0 glVertex2f
+ 0.0 dim second 1 + glVertex2f
+ content-background-colour >rgba-components drop 0.0 glColor4f
+ shadow-width dim second 1 + glVertex2f
+ shadow-width 0.0 glVertex2f
+ content-background-colour >rgba-components glColor4f
+ dim first 0.0 glVertex2f
+ dim first dim second 1 + glVertex2f
+ content-background-colour >rgba-components drop 0.0 glColor4f
+ dim first shadow-width - dim second 1 + glVertex2f
+ dim first shadow-width - 0.0 glVertex2f
+ glEnd ;
+
+: draw-title ( dim gradient -- )
+ [ draw-gradient ] [ draw-underline ] [ drop draw-shadows ] 2tri ;
+
+M: title-gradient draw-interior
+ [ dim>> ] dip colors>> draw-title ;
+
+M: title-gradient pen-background
+ 2drop transparent ;
+
+M: title-gradient pen-foreground
+ nip foreground>> ;
[ <down-button> f track-add ]
[ drop <gadget> { 1 1 } >>dim f track-add ]
} cleave ;
+
+! skov
+! : <slider> ( range orientation -- slider )
+! slider new-track
+! swap >>model
+! 16 >>line
+! dup orientation>> {
+! [ <thumb> >>thumb ]
+! [ <elevator> >>elevator ]
+! [ drop dup add-thumb-to-elevator 1 track-add ]
+! } cleave ;
+
+! M: slider pref-dim*
+! [ slider-enabled? [ { 16 16 } ] [ { 0 0 } ] if ]
+! [ drop { 0 0 } ]
+! [ orientation>> ] tri set-axis ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache combinators images images.loader
kernel math namespaces opengl opengl.textures sequences
-splitting system ui.gadgets.worlds vocabs ;
+splitting system ui.gadgets.worlds vocabs math.vectors colors ;
IN: ui.images
TUPLE: image-name path ;
: draw-scaled-image ( dim image -- )
rendered-image draw-scaled-texture ;
-: image-dim ( image -- dim )
- cached-image [ dim>> ] [ 2x?>> [ [ 2 / ] map ] when ] bi ;
+! : image-dim ( image -- dim )
+! cached-image [ dim>> ] [ 2x?>> [ [ 2 / ] map ] when ] bi ;
+
+! skov
+: image-dim ( image-name -- dim )
+ cached-image dim>> 1/2 v*n ;
{
{ [ os macosx? ] [ "images.loader.cocoa" require ] }
--- /dev/null
+USING: accessors arrays assocs colors combinators
+combinators.short-circuit combinators.smart kernel locals math
+math.functions math.order ranges math.vectors opengl.gl
+sequences ui.gadgets ui.gadgets.packs ui.pens ui.pens.caching
+ui.pens.gradient system ;
+IN: ui.pens.gradient-rounded
+
+TUPLE: gradient-shape < caching-pen colors foreground shape last-vertices last-colors ;
+TUPLE: gradient-squircle < gradient-shape ;
+TUPLE: gradient-arrow < gradient-shape ;
+TUPLE: gradient-pointy < gradient-shape ;
+TUPLE: gradient-dynamic-shape < gradient-shape selected? ;
+
+: <gradient-squircle> ( colors foreground -- gradient )
+ gradient-squircle new swap >>foreground swap >>colors ;
+
+: <gradient-arrow> ( colors foreground -- gradient )
+ gradient-arrow new swap >>foreground swap >>colors ;
+
+: <gradient-pointy> ( colors foreground -- gradient )
+ gradient-pointy new swap >>foreground swap >>colors ;
+
+: <gradient-dynamic-shape> ( colors foreground selected? -- gradient )
+ gradient-dynamic-shape new swap >>selected? swap >>foreground swap >>colors ;
+
+<PRIVATE
+
+CONSTANT: tau 6.283185307179586
+CONSTANT: points 100
+
+: squircle-point ( theta -- xy )
+ [ cos ] [ sin ] bi [ [ abs sqrt ] [ sgn ] bi * 0.5 * 0.5 + ] bi@ 2array ;
+
+:: tan-point ( y slope -- xy )
+ y tau * 4 / tan 300 / 0.5 min y slope / + y 2array ;
+
+:: squircle ( -- seq )
+ 1/4 tau * 3/4 tau * 1/2 tau * points / <range> [ squircle-point ] map ;
+
+:: arrow ( -- seq )
+ { { -0.25 1 } { 0 0.5 } { -0.25 0 } } ;
+
+:: wide-narrow ( slope -- seq )
+ 0.0 1.0 1 points / <range> [ slope tan-point ] map reverse ;
+
+: narrow-wide ( slope -- seq )
+ wide-narrow unzip [ reverse ] dip zip ;
+
+:: wide-narrow-wide ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ min ] 2map ] dip zip ;
+
+:: narrow-wide-narrow ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ max ] 2map ] dip zip ;
+
+:: vertices ( dim left-shape right-shape symmetric? -- seq )
+ dim first2 :> ( x y )
+ left-shape right-shape [ call( -- seq ) [ y v*n ] map ] bi@
+ reverse symmetric? [ [ first2 [ neg ] dip 2array ] map ] unless
+ [ first2 swap x swap - swap 2array ] map append
+ x 2 / y 2 / 2array prefix dup second suffix ;
+
+:: interp-color ( x colors -- seq )
+ colors [ >rgba-components 4array ] map first2 zip [ first2 dupd - x * - ] map ;
+
+:: vertices-colors ( dim seq colors -- seq )
+ seq [ second dim second / colors interp-color ] map ;
+
+: draw-triangle-fan ( vertices colors -- )
+ GL_TRIANGLE_FAN glBegin
+ [ first3 glColor3f first2 glVertex2f ] 2each
+ glEnd ;
+
+:: gradient-start ( edge center -- s )
+ center first2 :> ( xc yc )
+ edge first2 :> ( xe ye )
+ 8 xe xc - sq ye yc - sq + sqrt / :> alpha
+ xe xe xc - alpha * -
+ ye ye yc - alpha * - 8 max 16 min 2array ;
+
+: draw-triangle-fan-selected ( vertices -- )
+ unclip dupd [ gradient-start ] curry map
+ GL_TRIANGLE_STRIP glBegin
+ [ 1.0 1.0 1.0 0.0 glColor4f first2 glVertex2f
+ 1.0 1.0 1.0 0.6 glColor4f first2 glVertex2f ] 2each
+ glEnd ;
+
+: left ( gadget -- dim ) screen-loc first ;
+: right ( gadget -- dim ) [ screen-loc first ] [ dim>> first ] bi + ;
+
+: default-value ( side -- x )
+ \ left = 10000 0 ? ;
+
+: compare ( x y side -- ? )
+ \ left = [ 3 - < ] [ 3 + > ] if ;
+
+:: above ( gadget side -- dim )
+ gadget parent>> gadget-child children>> [ empty? not ]
+ [ side \ left = [ first ] [ last ] if children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: below ( gadget side -- dim )
+ gadget parent>> parent>>
+ [ dup parent>> children>> { [ length 1 > nip ] [ second = not ] } 2&& ]
+ [ parent>> children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: above-wider? ( gadget side -- ? )
+ gadget [ side above ] [ side execute( x -- x ) ] bi side compare ;
+
+:: below-wider? ( gadget side -- ? )
+ gadget [ side below ] [ side execute( x -- x ) ] bi side compare ;
+
+:: find-half-shape ( gadget side -- shape ) {
+ { [ gadget left 10 < ] [ [ squircle ] ] }
+ { [ gadget side above-wider? gadget side below-wider? and ] [ [ 6 wide-narrow-wide ] ] }
+ { [ gadget side above-wider? gadget side below-wider? not and ] [ [ 6 wide-narrow ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? and ] [ [ 6 narrow-wide ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? not and ] [ [ 6 narrow-wide-narrow ] ] }
+ } cond ;
+
+: find-shape ( gadget -- left-shape right-shape )
+ [ \ left find-half-shape ] [ \ right find-half-shape ] bi ;
+
+:: (recompute-pen) ( gadget gradient left-shape right-shape symmetric? -- )
+ gadget dim>> dup left-shape right-shape symmetric? vertices dup gradient last-vertices<<
+ gradient colors>> vertices-colors gradient last-colors<< ;
+
+M: gradient-squircle recompute-pen ( gadget gradient -- )
+ [ squircle ] dup t (recompute-pen) ;
+
+M: gradient-arrow recompute-pen ( gadget gradient -- )
+ [ arrow ] dup f (recompute-pen) ;
+
+M: gradient-pointy recompute-pen ( gadget gradient -- )
+ [ 1.5 narrow-wide-narrow ] dup t (recompute-pen) ;
+
+M:: gradient-dynamic-shape recompute-pen ( gadget gradient -- )
+ gadget gradient gadget find-shape t (recompute-pen) ;
+
+PRIVATE>
+
+M: gradient-shape draw-interior
+ [ compute-pen ]
+ [ last-vertices>> ]
+ [ last-colors>> draw-triangle-fan ] tri ;
+
+M: gradient-shape pen-background
+ 2drop transparent ;
+
+M: gradient-shape pen-foreground
+ nip foreground>> ;
+
+M: gradient-dynamic-shape draw-interior
+ [ call-next-method ]
+ [ selected?>> ]
+ [ last-vertices>> ] tri
+ [ draw-triangle-fan-selected ] curry when ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math opengl sequences ui.images ui.pens ;
+USING: accessors kernel math opengl sequences ui.images ui.pens colors ;
IN: ui.pens.image
! Image pen
] if ;
M: image-pen pen-pref-dim nip image>> image-dim ;
+
+M: image-pen pen-background
+ 2drop transparent ;
--- /dev/null
+USING: accessors colors kernel locals math opengl opengl.gl
+sequences ui.pens ui.tools.environment.theme system ;
+IN: ui.pens.title-gradient
+
+TUPLE: title-gradient colors foreground selected? ;
+
+: <title-gradient> ( colors foreground selected? -- gradient )
+ title-gradient new swap >>selected? swap >>foreground swap >>colors ;
+
+:: draw-gradient ( dim gradient -- )
+ GL_QUADS glBegin
+ gradient first >rgba-components glColor4f
+ 0.0 0.0 glVertex2f
+ dim first 0.0 glVertex2f
+ gradient second >rgba-components glColor4f
+ dim first2 glVertex2f
+ 0.0 dim second glVertex2f
+ glEnd ;
+
+:: draw-underline ( dim gradient -- )
+ 1 gl-scale glLineWidth
+ GL_LINES glBegin
+ gradient first >rgba-components glColor4f
+ 0.0 dim second glVertex2f
+ dim first2 glVertex2f
+ glEnd ;
+
+CONSTANT: shadow-width 20.0
+
+:: draw-shadows ( dim -- )
+ GL_QUADS glBegin
+ content-background-colour >rgba-components glColor4f
+ 0.0 0.0 glVertex2f
+ 0.0 dim second 1 + glVertex2f
+ content-background-colour >rgba-components drop 0.0 glColor4f
+ shadow-width dim second 1 + glVertex2f
+ shadow-width 0.0 glVertex2f
+ content-background-colour >rgba-components glColor4f
+ dim first 0.0 glVertex2f
+ dim first dim second 1 + glVertex2f
+ content-background-colour >rgba-components drop 0.0 glColor4f
+ dim first shadow-width - dim second 1 + glVertex2f
+ dim first shadow-width - 0.0 glVertex2f
+ glEnd ;
+
+: draw-title ( dim gradient -- )
+ [ draw-gradient ] [ draw-underline ] [ drop draw-shadows ] 2tri ;
+
+M: title-gradient draw-interior
+ [ dim>> ] dip colors>> draw-title ;
+
+M: title-gradient pen-background
+ 2drop transparent ;
+
+M: title-gradient pen-foreground
+ nip foreground>> ;
ui.gadgets.status-bar ui.gadgets.toolbar ui.gadgets.tracks
ui.gadgets.viewports ui.gadgets.worlds ui.gestures ui.pens.solid
ui.theme ui.tools.browser.history ui.tools.browser.popups
-ui.tools.common unicode vocabs ;
+ui.tools.common unicode vocabs ui.gadgets.buttons.activate ;
IN: ui.tools.browser
TUPLE: browser-gadget < tool history scroller search-field popup ;
[ ($navigation-path) ] bi
] with-nesting ;
+! : <help-header> ( browser-gadget -- gadget )
+! model>> [ '[ _ $title ] try ] <pane-control> ;
+
+! skov
: <help-header> ( browser-gadget -- gadget )
- model>> [ '[ _ $title ] try ] <pane-control> ;
+ horizontal <track> swap model>>
+ [ [ '[ _ $title ] try ] <pane-control> 1 track-add ]
+ [ <active/inactive> { 5 0 } <border> f track-add ] bi ;
: add-help-header ( track -- track )
dup <help-header> { 3 3 } <border>
"Browser" >>title
open-status-window ;
+! skov
+! : (browser-window) ( topic -- )
+! <browser-gadget>
+! <world-attributes>
+! "Browser" >>title
+! { windowed double-buffered multisampled
+! T{ samples f 4 } T{ sample-buffers f 1 } }
+! >>pixel-format-attributes
+! open-status-window ;
+
: browser-window ( -- )
"help.home" (browser-window) ;
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays code code.execution colors
+combinators combinators.short-circuit combinators.smart fry
+kernel listener locals locals math math.order math.statistics
+math.vectors models namespaces sequences splitting system
+ui.commands ui.gadgets ui.gadgets.borders
+ui.gadgets.buttons.round ui.gadgets.editors
+ui.gadgets.editors.private ui.gadgets.frames ui.gadgets.grids
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ui.pens.gradient-rounded ui.pens.solid ui.pens.tile
+ui.pens.title-gradient ui.render ui.text ui.tools.browser
+ui.tools.environment.theme ;
+FROM: code => call ;
+FROM: models => change-model ;
+IN: ui.tools.environment.cell
+
+CONSTANT: cell-height 24
+CONSTANT: min-cell-width 30
+
+TUPLE: cell < border selection ;
+TUPLE: cell-editor < editor ;
+
+: <cell-editor> ( -- editor )
+ cell-editor new-editor ;
+
+: selected? ( cell -- ? )
+ [ control-value ] [ selection>> value>> [ result? ] [ parent>> ] smart-when ] bi eq? ;
+
+:: subtree-input? ( node -- ? )
+ node introduce?
+ node name>> empty? and
+ node [ quoted-node? ] find-parent and ;
+
+:: cell-colors ( cell -- bg-color text-color )
+ cell control-value
+ { { [ dup input/output? ] [ drop dark-background light-text-colour ] }
+ { [ dup text? ] [ drop white-background dark-text-colour ] }
+ { [ dup call? ] [ drop green-background dark-text-colour ] }
+ { [ dup getter? ] [ drop yellow-background dark-text-colour ] }
+ { [ dup setter? ] [ drop yellow-background dark-text-colour ] }
+ [ drop cell selected? active-background inactive-background ? light-text-colour ]
+ } cond ;
+
+:: cell-theme ( cell -- cell )
+ cell dup cell-colors
+ cell control-value name>> empty? [ faded-color ] when
+ cell selected?
+ cell control-value node? [ <gradient-dynamic-shape> ] [ <title-gradient> ] if
+ >>interior ;
+
+:: enter-name ( name cell -- cell )
+ cell control-value
+ { { [ name empty? ] [ ] }
+ { [ cell control-value call? not ] [ name >>name ] }
+ { [ cell control-value clone name >>name find-target empty? not ]
+ [ name >>name dup find-target [ length 1 > ] [ >>completion ] [ first >>target ] smart-if ] }
+ [ ]
+ } cond
+ cell set-control-value
+ cell control-value [ [ word? ] [ vocab? ] bi or ] find-parent [ ?define ] when*
+ cell selection>> notify-connections cell ;
+
+:: ?enter-name ( cell -- cell )
+ cell children>> [ editor? ] filter first editor-string dup empty?
+ [ drop cell ] [ cell enter-name ] if ;
+
+: replace-space ( char -- char )
+ [ CHAR: space = ] [ drop CHAR: ⎵ ] smart-when
+ [ CHAR: \t = ] [ drop CHAR: ⇥ ] smart-when ;
+
+: make-spaces-visible ( str -- str )
+ [ length 0 > ] [ unclip replace-space prefix ] smart-when
+ [ length 1 > ] [ unclip-last replace-space suffix ] smart-when ;
+
+: <cell> ( value selection -- node )
+ cell new { 12 0 } >>size min-cell-width cell-height 2array >>min-dim
+ swap >>selection swap <model> >>model horizontal >>orientation ;
+
+:: collapsed? ( cell -- ? )
+ cell control-value subtree-input?
+ cell selected? not and ;
+
+M:: cell model-changed ( model cell -- )
+ cell cell-colors :> text-color :> bg-color
+ cell dup clear-gadget
+ cell collapsed? [ "" ] [ model value>> name-or-default make-spaces-visible ] if
+ <label> set-font add-gadget
+ <cell-editor> f >>visible? set-font
+ [ text-color >>foreground transparent >>background ] change-font add-gadget
+ model value>> node? [
+ cell selected? model value>> parent>> and [
+ <shelf> { 5 0 } >>gap
+ inactive-background "✕"
+ [ drop model value>> remove-element cell selection>> set-model ] <round-button>
+ model value>> vocab? "Delete vocabulary" "Delete word" ? " ( Ctrl R )" append
+ >>tooltip add-gadget
+ model value>> word? [
+ inactive-background "↑"
+ [ drop model value>> left exchange-node-side cell selection>> set-model ] <round-button>
+ "Move up" >>tooltip add-gadget
+ inactive-background "↓"
+ [ drop model value>> right exchange-node-side cell selection>> set-model ] <round-button>
+ "Move down" >>tooltip add-gadget
+ ] when
+ add-gadget ] when
+ model value>> executable? [
+ cell selection>> value>> parent>> cell control-value eq? [
+ blue-background "Result"
+ [ drop model value>> cell selection>> set-model ] <round-button>
+ "Show word ( Shift Enter )" >>tooltip
+ ] [
+ inactive-background "Result"
+ [ drop model value>> dup run-word result>> cell selection>> set-model ] <round-button>
+ "Show result ( Shift Enter )" >>tooltip
+ ] if add-gadget ] when
+ ] unless cell-theme drop ;
+
+M:: cell layout* ( cell -- )
+ cell children>> first { [ editor? ] [ editor-string empty? ] } 1&&
+ cell children>> second { [ editor? ] [ editor-string empty? not ] } 1&& or
+ [ 0 1 cell children>> exchange ] when
+ cell children>> first t >>visible? drop
+ cell children>> second f >>visible? drop
+ cell call-next-method
+ cell children>> rest rest [
+ dup pack? not cell dim>> first 68 - 15 ? 5 2array >>loc
+ dup pref-dim >>dim drop
+ ] each ;
+
+M: cell focusable-child*
+ children>> [ editor? ] filter first ;
+
+M: cell graft*
+ [ selected? ] [ request-focus ] smart-when* ;
+
+M: cell pref-dim*
+ dup call-next-method swap collapsed? [ 12 over set-second ] when ;
+
+:: select-cell ( cell -- )
+ cell control-value name>> "⨁" = [
+ cell parent>> control-value [ vocab? ] find-parent
+ cell control-value "" >>name add-element drop
+ ] when
+ cell control-value cell selection>> set-model ;
+
+:: change-cell ( cell quot -- )
+ cell control-value node? [ cell selection>> quot change-model ] when ; inline
+
+:: change-cell* ( cell quot -- )
+ cell control-value node? [ cell selection>> quot change-model ] unless ; inline
+
+: convert-cell ( cell class -- )
+ [ ?change-node-type ] curry change-cell ;
+
+: show-help-on-word ( cell -- )
+ [ control-value target>>
+ [ (browser-window) ] [ show-browser ] if*
+ ] with-interactive-vocabs ;
+
+:: ask-for-completion ( cell -- )
+ cell children>> [ editor? ] filter first editor-string
+ [ cell model>> [ swap [ >>name ] [ matching-words >>completion ] bi ] with change-model
+ cell selection>> notify-connections ] unless-empty ;
+
+cell H{
+ { T{ button-down } [ select-cell ] }
+ { lose-focus [ ?enter-name drop ] }
+ { T{ key-down f f "RET" } [ ?enter-name drop ] }
+ { T{ key-down f { C+ } "w" } [ ?enter-name call convert-cell ] }
+ { T{ key-down f { C+ } "W" } [ ?enter-name call convert-cell ] }
+ { T{ key-down f { C+ } "i" } [ ?enter-name introduce convert-cell ] }
+ { T{ key-down f { C+ } "I" } [ ?enter-name introduce convert-cell ] }
+ { T{ key-down f { C+ } "o" } [ ?enter-name return convert-cell ] }
+ { T{ key-down f { C+ } "O" } [ ?enter-name return convert-cell ] }
+ { T{ key-down f { C+ } "t" } [ ?enter-name text convert-cell ] }
+ { T{ key-down f { C+ } "T" } [ ?enter-name text convert-cell ] }
+ { T{ key-down f { C+ } "s" } [ ?enter-name setter convert-cell ] }
+ { T{ key-down f { C+ } "S" } [ ?enter-name setter convert-cell ] }
+ { T{ key-down f { C+ } "g" } [ ?enter-name getter convert-cell ] }
+ { T{ key-down f { C+ } "G" } [ ?enter-name getter convert-cell ] }
+ { T{ key-down f { C+ } "r" } [ [ replace-parent ] change-cell ] }
+ { T{ key-down f { C+ } "R" } [ [ replace-parent ] change-cell ] }
+ { T{ key-down f { C+ } "d" } [ [ remove-element ] change-cell ] }
+ { T{ key-down f { C+ } "D" } [ [ remove-element ] change-cell ] }
+ { T{ key-down f { C+ } "q" } [ [ (un)quote ] change-cell ] }
+ { T{ key-down f { C+ } "Q" } [ [ (un)quote ] change-cell ] }
+ { T{ key-down f f "UP" } [ ?enter-name [ child-node ] change-cell ] }
+ { T{ key-down f f "DOWN" } [ ?enter-name [ parent-node ] change-cell ] }
+ { T{ key-down f f "LEFT" } [ ?enter-name [ left side-node ] change-cell ] }
+ { T{ key-down f f "RIGHT" } [ ?enter-name [ right side-node ] change-cell ] }
+ { T{ key-down f { A+ } "LEFT" } [ ?enter-name [ left exchange-node-side ] change-cell ] }
+ { T{ key-down f { A+ } "RIGHT" } [ ?enter-name [ right exchange-node-side ] change-cell ] }
+ { T{ key-down f { M+ } "LEFT" } [ ?enter-name [ left insert-node-side ] change-cell ] }
+ { T{ key-down f { M+ } "RIGHT" } [ ?enter-name [ right insert-node-side ] change-cell ] }
+ { T{ key-down f { M+ } "DOWN" } [ ?enter-name [ insert-new-parent ] change-cell ] }
+ { T{ key-down f { C+ } "h" } [ show-help-on-word ] }
+ { T{ key-down f { C+ } "H" } [ show-help-on-word ] }
+ { T{ key-down f f "TAB" } [ ask-for-completion ] }
+ { T{ key-down f f "ESC" } [ [ parent-node ] change-cell* ] }
+} set-gestures
+
+: previous-character* ( editor -- )
+ [ editor-caret second 0 = ]
+ [ parent>> ?enter-name [ left side-node ] change-cell ]
+ [ previous-character ] smart-if ;
+
+: next-character* ( editor -- )
+ [ [ editor-caret second ] [ editor-string length ] bi = ]
+ [ parent>> ?enter-name [ right side-node ] change-cell ]
+ [ next-character ] smart-if ;
+
+cell-editor "caret-motion" f {
+ { T{ key-down f f "LEFT" } previous-character* }
+ { T{ key-down f f "RIGHT" } next-character* }
+} define-command-map
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors code code.execution code.import-export
+combinators kernel listener locals memory models namespaces
+sequences ui ui.commands ui.gadgets ui.gadgets.scrollers
+ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.worlds
+ui.gestures ui.pixel-formats ui.tools.browser ui.tools.common
+ui.tools.environment.cell ui.tools.environment.navigation
+ui.tools.environment.theme ;
+FROM: models => change-model ;
+IN: ui.tools.environment
+
+TUPLE: environment < tool ;
+
+environment { 700 600 } set-tool-dim
+
+:: <environment> ( -- gadget )
+ skov-root get-global <model> :> model
+ vertical environment new-track model >>model
+ model <navigation> <scroller> 1 track-add
+ with-background ;
+
+: environment-window ( -- )
+ [ <environment>
+ <world-attributes>
+ { windowed double-buffered multisampled
+ T{ samples f 4 } T{ sample-buffers f 1 } }
+ >>pixel-format-attributes
+ "Skov" >>title open-status-window ] with-ui ;
+
+: save-image-and-vocabs ( env -- )
+ drop save export-vocabs ;
+
+: load-vocabs ( env -- )
+ update-skov-root skov-root get-global swap set-control-value ;
+
+environment H{
+ { T{ key-down f { C+ } "h" } [ drop show-browser ] }
+ { T{ key-down f { C+ } "H" } [ drop show-browser ] }
+ { save-action [ save-image-and-vocabs ] }
+ { open-action [ load-vocabs ] }
+} set-gestures
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors colors kernel locals math math.constants
+math.functions opengl.gl sequences ui.gadgets system
+ui.render ui.tools.environment.theme ;
+IN: ui.tools.environment.navigation.dot-pattern
+
+TUPLE: dot-pattern < gadget ;
+
+: <dot-pattern> ( child -- gadget )
+ dot-pattern new swap add-gadget ;
+
+CONSTANT: dr 8
+
+:: draw-dot-ring ( x y n -- )
+ n 6 * <iota> [
+ tau * 6 n * /
+ [ sin n * dr * x 2 /i + dup [ 3 > ] [ x 3 - < ] bi and ]
+ [ cos n * dr * 44 + dup [ 3 > ] [ y 3 - < ] bi and ] bi
+ swapd and [ glVertex2f ] [ drop drop ] if
+ ] each ;
+
+M: dot-pattern draw-gadget*
+ os windows? [ drop ] [
+ dim>> [ first2 ] [ first 2 / dr /i ] bi
+ GL_POINT_SMOOTH glEnable
+ 9 glPointSize
+ GL_POINTS glBegin
+ blue-background second >rgba-components drop 0.12 glColor4f
+ <iota> [ draw-dot-ring ] 2with each
+ glEnd
+ ] if ;
+
+M: dot-pattern pref-dim*
+ drop { 0 65 } ;
+
+M: dot-pattern layout*
+ [ dim>> first ] [ gadget-child ] bi dup pref-dim second
+ swapd 2array >>dim { 0 23 } >>loc drop ;
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors code code.execution colors combinators
+combinators.smart kernel locals models sequences system
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.buttons.round ui.gadgets.icons ui.gadgets.labels
+ui.gadgets.packs ui.gestures ui.pens.gradient-rounded
+ui.pens.tile ui.tools.environment.cell ui.tools.environment.tree
+ui.tools.environment.navigation.dot-pattern
+ui.tools.environment.theme ui.tools.environment ;
+FROM: models => change-model ;
+IN: ui.tools.environment.navigation
+
+TUPLE: navigation < pack ;
+
+: <category> ( background name -- gadget )
+ <label>
+ [ t >>bold? ] change-font { 26 0 } <border>
+ swap dark-text-colour <gradient-pointy> >>interior
+ { 0 22 } >>min-dim horizontal >>orientation ;
+
+: <name-bar> ( vocab/word selection -- gadget )
+ <cell> { 0 30 } >>min-dim ;
+
+: <navigation> ( model -- navigation )
+ navigation new swap >>model vertical >>orientation 1 >>fill ;
+
+:: new-item ( navigation class -- )
+ navigation control-value [ vocab? ] find-parent
+ class add-from-class contents>> last navigation set-control-value ;
+
+: find-navigation ( gadget -- navigation )
+ [ navigation? ] find-parent ;
+
+: set-children-font ( gadget -- gadget )
+ dup children>> [ [ label? ] [ set-result-font drop ] [ set-children-font drop ] smart-if ] each ;
+
+M:: navigation model-changed ( model gadget -- )
+ gadget dup clear-gadget
+ model value>> parents [ vocab? ] filter reverse
+ dup last :> voc
+ [ model <name-bar> ] map add-gadgets
+ blue-background "Vocabularies" <category> { 0 10 } <border> <dot-pattern> add-gadget
+ voc contents>> [ vocab? ] filter vocab new "⨁" >>name suffix [ model <name-bar> ] map add-gadgets
+ green-background "Words" <category> { 0 10 } <border> <dot-pattern> add-gadget
+ voc contents>> [ word? ] filter word new "⨁" >>name suffix [
+ [ model <name-bar> add-gadget ]
+ [ [ model value>> eq? ]
+ [ <tree-editor> { 10 15 } <border> add-gadget ] smart-when* ]
+ [ [ model value>> parent>> eq? model value>> result? and ]
+ [ result>> contents>> set-children-font { 10 45 } <border> add-gadget ] smart-when* ] tri
+ ] each drop ;
+
+: toggle-result ( nav -- )
+ model>> [ {
+ { [ dup executable? ] [ dup run-word result>> ] }
+ { [ dup result? ] [ parent>> ] }
+ [ ]
+ } cond ] change-model ;
+
+navigation H{
+ { T{ key-down f { C+ } "v" } [ vocab new-item ] }
+ { T{ key-down f { C+ } "V" } [ vocab new-item ] }
+ { T{ key-down f { C+ } "n" } [ word new-item ] }
+ { T{ key-down f { C+ } "N" } [ word new-item ] }
+ { T{ key-down f { S+ } "UP" } [ model>> [ [ result? not ] find-parent left side-node ] change-model ] }
+ { T{ key-down f { S+ } "DOWN" } [ model>> [ [ result? not ] find-parent right side-node ] change-model ] }
+ { T{ key-down f { S+ } "RET" } [ toggle-result ] }
+} set-gestures
--- /dev/null
+! Copyright (C) 2015 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs colors kernel math math.parser sequences
+sorting sorting.human ui.pens.solid ;
+IN: ui.tools.environment.theme
+
+CONSTANT: content-background-colour COLOR: #002b36
+
+CONSTANT: dark-background { COLOR: light-gray COLOR: dark-gray }
+CONSTANT: green-background { COLOR: gray68 COLOR: gray4 }
+CONSTANT: white-background { COLOR: gray2 COLOR: gray2 }
+CONSTANT: blue-background { COLOR: solarized-base02 COLOR: gray6 }
+CONSTANT: red-background { COLOR: DodgerBlue4 COLOR: gray6 }
+CONSTANT: yellow-background { COLOR: gray5 COLOR: gray4 }
+CONSTANT: inactive-background { COLOR: dark-green COLOR: FactorDarkGreen }
+CONSTANT: active-background { COLOR: DeepSkyBlue4 COLOR: dark-green }
+
+CONSTANT: content-text-colour COLOR: solarized-base02
+CONSTANT: dark-text-colour COLOR: black
+CONSTANT: light-text-colour COLOR: gray2
+CONSTANT: faded-text-colour COLOR: gray2
+
+: set-small-font ( label -- label )
+ [ 13 >>size t >>bold? ] change-font ;
+
+: set-font ( label -- label )
+ [ 15 >>size t >>bold? ] change-font ;
+
+: set-result-font ( label -- label )
+ [ 17 >>size t >>bold? content-text-colour >>foreground ] change-font ;
+
+: faded-color ( rgba -- rgba )
+ >rgba-components drop 0.4 <rgba> ;
+
+: with-background ( gadget -- gadget )
+ content-background-colour <solid> >>interior ;
+
+
--- /dev/null
+! Copyright (C) 2016-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: code code.factor-abstraction continuations kernel models
+ui.gadgets.borders ui.gadgets.labels ui.tools.environment.tree words ;
+
+IN: ui.tools.environment.tree.help-tree
+
+: <help-tree> ( factor-word -- gadget )
+ word new swap call-from-factor add-element
+ <model> <tree> { 20 10 } <filled-border> ;
+
+: <definition-tree> ( factor-word -- gadget )
+ [ word-from-factor <model> <tree> { 5 5 } <border> ]
+ [ drop drop "(cannot be displayed)" <label> ] recover ;
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays code combinators.short-circuit kernel
+locals math math.order math.vectors models sequences splitting
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons.round
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.packs.private
+ui.gestures ui.pens.gradient-rounded ui.pens.solid
+ui.tools.environment.cell ui.tools.environment.tree ui.tools.environment.theme ;
+FROM: code => call ;
+FROM: models => change-model ;
+IN: ui.tools.environment.tree
+
+TUPLE: tree < pack ;
+TUPLE: tree-control < pack ;
+TUPLE: tree-toolbar < tree-control ;
+TUPLE: path-display < tree-control selected ;
+TUPLE: special-pile < pack ;
+TUPLE: path-item < pack word ;
+TUPLE: path-cell < border word? ;
+
+: <special-pile> ( -- pack )
+ special-pile new vertical >>orientation ;
+
+: center-point ( gadget -- x )
+ [ [ parent>> loc>> ] [ loc>> ] bi v+ ] [ dim>> ] bi [ first ] bi@ 2 /i + ;
+
+M:: special-pile layout* ( pack -- )
+ pack call-next-method
+ pack children>> first2 :> ( shelf cell )
+ shelf layout
+ shelf children>> empty? [
+ shelf children>> [ first ] [ last ] bi [ children>> last center-point ] bi@ :> ( a b )
+ cell pref-dim first2 [ b a - 20 + max ] dip 2array cell dim<<
+ a b + 2 /i cell dim>> first 2 /i - dup neg?
+ [ neg shelf loc>> second 2array shelf loc<< ]
+ [ cell loc>> second 2array cell loc<< ] if
+ ] unless ;
+
+: <quoted-cell> ( cell -- pile )
+ <special-pile> <shelf> rot add-gadget add-gadget <gadget> { 0 6 } >>dim add-gadget ;
+
+:: build-tree ( node selection -- pile )
+ <special-pile> { 0 1 } >>gap
+ <shelf> { 8 0 } >>gap 1 >>align
+ node contents>> [ selection build-tree ] map add-gadgets add-gadget
+ node selection <cell> add-gadget
+ node quoted?>> [ <quoted-cell> ] when ;
+
+: <tree> ( word -- pile )
+ tree new horizontal >>orientation swap >>model { 15 0 } >>gap 1 >>align ;
+
+M:: tree model-changed ( model tree -- )
+ tree clear-gadget
+ tree model value>> [ word? ] find-parent ?add-words
+ contents>> [ model build-tree ] map add-gadgets drop ;
+
+M: tree-control pref-dim*
+ call-next-method first2 20 max 2array ;
+
+: <tree-toolbar> ( model -- gadget )
+ tree-toolbar new horizontal >>orientation { 5 0 } >>gap swap >>model ;
+
+:: add-button ( toolbar cond-quot color letter action-quot tooltip -- toolbar )
+ toolbar dup control-value cond-quot call( x -- ? )
+ [ color letter [ drop toolbar model>> action-quot change-model ] ]
+ [ inactive-background "" [ drop ] ] if <round-button>
+ tooltip >>tooltip add-gadget ;
+
+M:: tree-toolbar model-changed ( model tree-toolbar -- )
+ tree-toolbar dup clear-gadget
+ model value>> [ word? ] find-parent ?add-words drop
+ model value>> node? [
+ [ top-node? ] dark-background "I" [ introduce ?change-node-type ]
+ "Convert cell into an input cell ( Control I )" add-button
+ [ top-node? ] yellow-background "G" [ getter ?change-node-type ]
+ "Convert cell into a get cell ( Control G )" add-button
+ [ top-node? ] white-background "T" [ text ?change-node-type ]
+ "Convert cell into a text cell ( Control T )" add-button
+ <gadget> add-gadget
+ [ drop t ] green-background "W" [ call ?change-node-type ]
+ "Convert cell into a word cell ( Control W )" add-button
+ <gadget> add-gadget
+ [ bottom-node? ] yellow-background "S" [ setter ?change-node-type ]
+ "Convert cell into a set cell ( Control S )" add-button
+ [ [ bottom-node? ] [ no-return? ] [ return? ] tri or and ]
+ dark-background "O" [ return ?change-node-type ]
+ "Convert cell into an output cell ( Control O )" add-button
+ <gadget> { 20 0 } >>dim add-gadget
+ model value>> bottom-node?
+ [ inactive-background "" [ drop ] ]
+ [ blue-background model value>> quoted?>> "︾" "︽" ?
+ [ drop model [ (un)quote ] change-model ] ] if <round-button>
+ model value>> quoted?>> "Unquote" "Quote" ? " ( Control Q )" append
+ >>tooltip add-gadget
+ <gadget> add-gadget
+ [ leftmost-node? not ] blue-background "←" [ left exchange-node-side ]
+ "Exchange cell and cell on the left ( Command ← )" add-button
+ [ rightmost-node? not ] blue-background "→" [ right exchange-node-side ]
+ "Exchange cell and cell on the right ( Command → )" add-button
+ <gadget> add-gadget
+ [ parent>> { [ word? ] [ variadic? ] } 1|| ]
+ blue-background "⇐" [ left insert-node-side ]
+ "Insert new cell on the left ( Option ← )" add-button
+ [ parent>> { [ word? ] [ variadic? ] } 1|| ]
+ blue-background "⇒" [ right insert-node-side ]
+ "Insert new cell on the right ( Option → )" add-button
+ [ drop t ] blue-background "⇓" [ insert-new-parent ]
+ "Insert new cell below ( Option ↓ )" add-button
+ <gadget> add-gadget
+ [ bottom-node? not ] red-background "↓" [ replace-parent ]
+ "Replace cell below ( Control R )" add-button
+ [ drop t ]
+ red-background "✕" [ remove-element ]
+ "Delete cell and everything above ( Control D )" add-button
+ ] when drop ;
+
+: path-cell-colors ( cell -- bg-color text-color )
+ word?>> [ green-background dark-text-colour ]
+ [ blue-background dark-text-colour ] if ;
+
+: <path-cell> ( name word? -- node )
+ path-cell new { 5 0 } >>size { 0 18 } >>min-dim
+ swap >>word? swap " " append <label> set-small-font add-gadget
+ dup path-cell-colors <gradient-arrow> >>interior ;
+
+: <path-item> ( factor-word -- gadget )
+ dup [ vocabulary>> "." split [ f <path-cell> ] map ] [ name>> t <path-cell> ] bi suffix
+ path-item new swap add-gadgets swap >>word horizontal >>orientation { 7 0 } >>gap ;
+
+: <path-display> ( model -- gadget )
+ path-display new vertical >>orientation { 0 5 } >>gap swap >>model ;
+
+M:: path-display model-changed ( model path-display -- )
+ path-display dup clear-gadget
+ model value>> call? [
+ model value>> target>> number? [
+ model value>> completion>>
+ [ model value>> completion>> [ <path-item> ] map add-gadgets ]
+ [ model value>> target>> [ <path-item> add-gadget ] when* ] if
+ ] unless
+ ] when drop ;
+
+: <tree-editor> ( word -- gadget )
+ <pile> { 0 30 } >>gap 1/2 >>align swap <model>
+ [ <tree-toolbar> ] [ <tree> ] [ <path-display> ] tri 3array add-gadgets ;
+
+: select-nothing ( tree -- )
+ model>> [ [ node? not ] find-parent ] change-model ;
+
+: choose-word ( path-item -- )
+ [ word>> ] [ parent>> model>> ] bi
+ [ swap >>target dup target>> name>> short-name >>name f >>completion ] with change-model ;
+
+: select-word ( path-item -- )
+ dark-background second <solid> >>interior relayout-1 ;
+
+: deselect-word ( path-item -- )
+ f >>interior relayout-1 ;
+
+tree H{
+ { T{ button-down } [ select-nothing ] }
+} set-gestures
+
+path-item H{
+ { T{ button-down } [ choose-word ] }
+} set-gestures
ui.tools.browser ui.tools.common ui.tools.debugger
ui.tools.error-list ui.tools.listener.completion
ui.tools.listener.history ui.tools.listener.popups vocabs
-vocabs.loader vocabs.parser vocabs.refresh words ;
+vocabs.loader vocabs.parser vocabs.refresh words ui.gadgets.borders
+ui.tools.environment ui.tools.environment.theme ;
IN: ui.tools.listener
TUPLE: interactor < source-editor
<listener-gadget>
dup "Listener" open-status-window ;
-: listener-window ( -- )
- [ listener-window* drop ] with-ui ;
+! : listener-window ( -- )
+! [ listener-window* drop ] with-ui ;
+
+! skov
+: listener-window ( -- ) environment-window ;
\ listener-window H{ { +nullary+ t } } define-command
: get-listener ( -- listener )
[ listener-gadget? ] (get-listener) ;
-: show-listener ( -- )
- get-listener drop ;
+! : show-listener ( -- )
+! get-listener drop ;
+
+! skov
+: show-listener ( -- ) [ border? ] find-window [ raise-window ] [ environment-window ] if* ;
\ show-listener H{ { +nullary+ t } } define-command
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }
{ T{ key-down f { C+ } "d" } delete-next-character/eof }
+ { T{ key-down f { C+ } "k" } clear-editor }
} define-command-map
interactor "completion" f {
} define-command-map
listener-gadget "multi-touch" f {
+ { left-action recall-previous }
+ { right-action recall-next }
{ up-action refresh-all }
} define-command-map
M: listener-gadget ungraft*
[ com-end ] [ call-next-method ] bi ;
+<PRIVATE
+
+:: make-font-style ( family size -- assoc )
+ H{ } clone
+ family font-name pick set-at
+ size font-size pick set-at ;
+
+PRIVATE>
+
:: set-listener-font ( family size -- )
get-listener input>> :> interactor
interactor output>> :> output
{ T{ key-down f ${ os macosx? M+ C+ ? } "-" } com-font-size-minus }
{ T{ key-down f ${ os macosx? M+ C+ ? } "0" } com-font-size-normal }
} define-command-map
+
+USE: lists.lazy
+USE: math.trig
+
+interactive-vocabs [ {
+ "io.encodings.utf8"
+ "io.encodings.binary"
+ "io.encodings.ascii"
+ "io.binary"
+ "io.directories"
+ "io.directories.hierarchy"
+ "lists.lazy"
+ "splitting"
+ "math.functions"
+ "math.trig"
+ "math.vectors"
+ "math.intervals"
+ "math.statistics"
+ "math.parser"
+ "sequences.deep"
+ "sequences.extras"
+ "sequences.generalizations"
+ "binary-search"
+ "vectors"
+ "quotations"
+ "byte-arrays"
+ "deques"
+ "regexp"
+ "calendar"
+ "classes"
+ "unicode.case"
+ "unicode.categories"
+ "io.files.info"
+ "colors"
+ "colors.hex"
+ "timers"
+ "sets"
+ "globs"
+ "scratchpad"
+} append ] change-global
USING: io.pathnames kernel literals memory namespaces sequences
system tools.test ui ui.backend ui.commands ui.gestures
ui.tools.browser ui.tools.button-list ui.tools.common
-ui.tools.error-list ui.tools.listener vocabs.refresh ;
+ui.tools.error-list ui.tools.listener vocabs.refresh ui.tools.environment ;
IN: ui.tools
\ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command
{ T{ key-down f f "F11" } toggle-fullscreen }
} ? prepend define-command-map
+! : ui-tools-main ( -- )
+! f ui-stop-after-last-window? set-global
+! "resource:" absolute-path current-directory set-global
+! listener-window ;
+
+! skov
: ui-tools-main ( -- )
f ui-stop-after-last-window? set-global
- "resource:" absolute-path current-directory set-global
- listener-window ;
+ environment-window ;
MAIN: ui-tools-main
if [[ $OS == macosx ]] ; then
$ECHO "If you have Xcode 4.3 or higher installed, you must install the"
$ECHO "Command Line Tools from Xcode Preferences > Downloads in order"
- $ECHO "to build Factor."
+ $ECHO "to build Skov."
fi
exit_script 1;
}
return
fi
- # gcc and g++ will fail to correctly build Factor on Cygwin
+ # gcc and g++ will fail to correctly build Skov on Cygwin
test_programs_installed gcc g++
if [[ $? -ne 0 ]] ; then
[ -z "$CC" ] && CC=gcc
esac
}
-check_factor_exists() {
- if [[ -d "factor" ]] ; then
- $ECHO "A directory called 'factor' already exists."
+check_skov_exists() {
+ if [[ -d "skov" ]] ; then
+ $ECHO "A directory called 'skov' already exists."
$ECHO "Rename or delete it and try again."
exit_script 4
fi
echo "$WORD_OUT"
}
-set_factor_binary() {
+set_skov_binary() {
case $OS in
- windows) FACTOR_BINARY=factor.com ;;
- *) FACTOR_BINARY=factor ;;
+ windows) SKOV_BINARY=skov.com ;;
+ *) SKOV_BINARY=skov ;;
esac
}
-set_factor_library() {
+set_skov_library() {
case $OS in
- windows) FACTOR_LIBRARY=factor.dll ;;
- macosx) FACTOR_LIBRARY=libfactor.dylib ;;
- *) FACTOR_LIBRARY=libfactor.a ;;
+ windows) SKOV_LIBRARY=factor.dll ;;
+ macosx) SKOV_LIBRARY=libfactor.dylib ;;
+ *) SKOV_LIBRARY=libfactor.a ;;
esac
}
-set_factor_image() {
- FACTOR_IMAGE=factor.image
- FACTOR_IMAGE_FRESH=factor.image.fresh
+set_skov_image() {
+ SKOV_IMAGE=skov.image
+ SKOV_IMAGE_FRESH=skov.image.fresh
}
echo_build_info() {
$ECHO DEBUG=$DEBUG
$ECHO REPRODUCIBLE=$REPRODUCIBLE
$ECHO CURRENT_BRANCH=$CURRENT_BRANCH
- $ECHO FACTOR_BINARY=$FACTOR_BINARY
- $ECHO FACTOR_LIBRARY=$FACTOR_LIBRARY
- $ECHO FACTOR_IMAGE=$FACTOR_IMAGE
+ $ECHO SKOV_BINARY=$SKOV_BINARY
+ $ECHO SKOV_LIBRARY=$SKOV_LIBRARY
+ $ECHO SKOV_IMAGE=$SKOV_IMAGE
$ECHO MAKE_TARGET=$MAKE_TARGET
$ECHO BOOT_IMAGE=$BOOT_IMAGE
$ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
set_cc
find_word_size
set_current_branch
- set_factor_binary
- set_factor_library
- set_factor_image
+ set_skov_binary
+ set_skov_library
+ set_skov_image
set_build_info
set_downloader
set_boot_image_vars
fi
}
-cd_factor() {
- cd "factor"
+cd_skov() {
+ cd "skov"
check_ret cd
}
esac
}
-backup_factor() {
- $ECHO "Backing up factor..."
- $COPY $FACTOR_BINARY $FACTOR_BINARY.bak
- $COPY $FACTOR_LIBRARY $FACTOR_LIBRARY.bak
+backup_skov() {
+ $ECHO "Backing up skov..."
+ $COPY $SKOV_BINARY $SKOV_BINARY.bak
+ $COPY $SKOV_LIBRARY $SKOV_LIBRARY.bak
$COPY $BOOT_IMAGE $BOOT_IMAGE.bak
- $COPY $FACTOR_IMAGE $FACTOR_IMAGE.bak
+ $COPY $SKOV_IMAGE $SKOV_IMAGE.bak
$ECHO "Done with backup."
}
$ECHO ""
$ECHO "***GNUmakefile not found***"
$ECHO "You are likely in the wrong directory."
- $ECHO "Run this script from your factor directory:"
+ $ECHO "Run this script from your skov directory:"
$ECHO " ./build.sh"
exit_script 6
fi
invoke_make clean
}
-make_factor() {
- $ECHO "Building factor with $NUM_CORES cores"
+make_skov() {
+ $ECHO "Building skov with $NUM_CORES cores"
invoke_make CC=$CC CXX=$CXX $MAKE_TARGET -j$NUM_CORES
}
-make_clean_factor() {
+make_clean_skov() {
make_clean
- make_factor
+ make_skov
}
current_git_branch() {
}
copy_fresh_image() {
- $ECHO "Copying $FACTOR_IMAGE to $FACTOR_IMAGE_FRESH..."
- $COPY $FACTOR_IMAGE $FACTOR_IMAGE_FRESH
+ $ECHO "Copying $SKOV_IMAGE to $SKOV_IMAGE_FRESH..."
+ $COPY $SKOV_IMAGE $SKOV_IMAGE_FRESH
}
bootstrap() {
- ./$FACTOR_BINARY -i=$BOOT_IMAGE
- check_ret "./$FACTOR_BINARY bootstrap failed"
+ ./$SKOV_BINARY -i=$BOOT_IMAGE
+ check_ret "./$SKOV_BINARY bootstrap failed"
copy_fresh_image
}
install() {
- check_factor_exists
+ check_skov_exists
get_config_info
git_clone
- cd_factor
- make_factor
+ cd_skov
+ make_skov
set_boot_image_vars
get_boot_image
bootstrap
update() {
get_config_info
git_fetch
- backup_factor
- make_clean_factor
+ backup_skov
+ make_clean_skov
}
download_and_bootstrap() {
net_bootstrap_no_pull() {
get_config_info
- make_clean_factor
+ make_clean_skov
download_and_bootstrap
}
refresh_image() {
- ./$FACTOR_BINARY -e="USING: vocabs.loader vocabs.refresh system memory ; refresh-all save 0 exit"
- check_ret factor
+ ./$SKOV_BINARY -e="USING: vocabs.loader vocabs.refresh system memory ; refresh-all save 0 exit"
+ check_ret skov
}
make_boot_image() {
- ./$FACTOR_BINARY -run="bootstrap.image" "$MAKE_IMAGE_TARGET"
- check_ret factor
+ ./$SKOV_BINARY -run="bootstrap.image" "$MAKE_IMAGE_TARGET"
+ check_ret skov
}
install_deps_apt() {
usage() {
$ECHO "usage: $0 command [optional-target]"
$ECHO " install - git clone, compile, bootstrap"
- $ECHO " deps-apt - install required packages for Factor on Linux using apt"
- $ECHO " deps-pacman - install required packages for Factor on Linux using pacman"
- $ECHO " deps-dnf - install required packages for Factor on Linux using dnf"
- $ECHO " deps-pkg - install required packages for Factor on FreeBSD using pkg"
+ $ECHO " deps-apt - install required packages for Skov on Linux using apt"
+ $ECHO " deps-pacman - install required packages for Skov on Linux using pacman"
+ $ECHO " deps-dnf - install required packages for Skov on Linux using dnf"
+ $ECHO " deps-pkg - install required packages for Skov on FreeBSD using pkg"
$ECHO " deps-macosx - install git on MacOSX using port"
$ECHO " self-bootstrap - make local boot image, bootstrap"
$ECHO " self-update - git pull, recompile, make local boot image, bootstrap"
self-update) update; make_boot_image; bootstrap ;;
quick-update) update; refresh_image ;;
update|latest) update; download_and_bootstrap ;;
- compile) find_build_info; make_factor ;;
- recompile) find_build_info; make_clean; make_factor ;;
+ compile) find_build_info; make_skov ;;
+ recompile) find_build_info; make_clean; make_skov ;;
bootstrap) get_config_info; bootstrap ;;
net-bootstrap) net_bootstrap_no_pull ;;
make-target) FIND_MAKE_TARGET=true; ECHO=false; find_build_info; exit_script ;;
: all-integers? ( ... n quot: ( ... i -- ... ? ) -- ... ? )
[ 0 ] 2dip all-integers-from? ; inline
+
+: half ( x -- x/2 ) 2 / ;
+
+: special-times ( initial n quot -- final ) times ; inline
dup object bootstrap-word eq?
[ drop ] [ 1array [ declare ] curry compose ] if ;
+! : reader-word ( name -- word )
+! ">>" append "accessors" create-word
+! dup t "reader" set-word-prop ;
+
+! skov
: reader-word ( name -- word )
- ">>" append "accessors" create-word
+ [ ">>" append "accessors" create-word ]
+ [ " (accessor)" append >>name ] bi
dup t "reader" set-word-prop ;
: reader-props ( slot-spec -- assoc )
} 2cleave define-typecheck
] 2bi ;
+! : writer-word ( name -- word )
+! "<<" append "accessors" create-word
+! dup t "writer" set-word-prop ;
+
+! skov
: writer-word ( name -- word )
- "<<" append "accessors" create-word
+ [ "<<" append "accessors" create-word ]
+ [ " (writer)" append >>name ] bi
dup t "writer" set-word-prop ;
ERROR: bad-slot-value value class ;
} 2cleave define-typecheck
] 2bi ;
+! : setter-word ( name -- word )
+! ">>" prepend "accessors" create-word ;
+
+! skov
: setter-word ( name -- word )
- ">>" prepend "accessors" create-word ;
+ [ ">>" prepend "accessors" create-word ]
+ [ " (mutator)" append >>name ] bi ;
: define-setter ( name -- )
dup setter-word dup deferred? [
( object value -- object ) define-inline
] [ 2drop ] if ;
+! : changer-word ( name -- word )
+! "change-" prepend "accessors" create-word ;
+
+! skov
: changer-word ( name -- word )
- "change-" prepend "accessors" create-word ;
+ [ "change-" prepend "accessors" create-word ]
+ [ "change " prepend >>name ] bi ;
: define-changer ( name -- )
dup changer-word dup deferred? [
: slot-named ( name specs -- spec/f )
slot-named* nip ;
+
[ dup "syntax" lookup-word [ ] [ no-word-error ] ?if ] dip
define-syntax ;
+: false ( -- false ) f ;
+: true ( -- true ) t ;
+
[
{ "]" "}" ";" ">>" } [ define-delimiter ] each
projects / factor.git / commitdiff
