diff --git a/Info.plist b/Info.plist
new file mode 100644
index 0000000..fe1cf1f
--- /dev/null
+++ b/Info.plist
@@ -0,0 +1,34 @@
+
+
+
+
+ CFBundleDevelopmentRegion
+ English
+ CFBundleDisplayName
+ Voronoi
+ CFBundleExecutable
+ Voronoi
+ CFBundleIconFile
+
+ CFBundleIdentifier
+ com.psellos.Voronoi
+ CFBundleInfoDictionaryVersion
+ 6.0
+ CFBundleName
+ Voronoi
+ CFBundlePackageType
+ APPL
+ CFBundleSignature
+ ????
+ CFBundleShortVersionString
+ 1.0
+ CFBundleVersion
+ 1.0.0
+ UIStatusBarStyle
+ UIStatusBarStyleBlackOpaque
+ LSRequiresIPhoneOS
+
+ NSMainNibFile
+ Voronoi
+
+
diff --git a/MDepend b/MDepend
new file mode 100644
index 0000000..bef1520
--- /dev/null
+++ b/MDepend
@@ -0,0 +1,3 @@
+ViewDelegator.o: ViewDelegator.m ViewDelegator.h
+main.o: main.m
+wrap.o: wrap.m ViewDelegator.h wrap.h
diff --git a/MLDepend b/MLDepend
new file mode 100644
index 0000000..a50ab34
--- /dev/null
+++ b/MLDepend
@@ -0,0 +1,47 @@
+bzpdata.cmo: cocoa.cmi bzpdata.cmi
+bzpdata.cmx: cocoa.cmx bzpdata.cmi
+bzpdraw.cmo: uiBezierPath.cmi cocoa.cmi bzpdraw.cmi
+bzpdraw.cmx: uiBezierPath.cmx cocoa.cmx bzpdraw.cmi
+cocoa.cmo: cocoa.cmi
+cocoa.cmx: cocoa.cmi
+colorfield.cmo: uiKit.cmi uiBezierPath.cmi cocoa.cmi bzpdata.cmi \
+ colorfield.cmi
+colorfield.cmx: uiKit.cmx uiBezierPath.cmx cocoa.cmx bzpdata.cmx \
+ colorfield.cmi
+uiActionSheet.cmo: wrapper.cmi uiView.cmi uiActionSheet.cmi
+uiActionSheet.cmx: wrapper.cmx uiView.cmx uiActionSheet.cmi
+uiApplication.cmo: wrapper.cmi uiApplication.cmi
+uiApplication.cmx: wrapper.cmx uiApplication.cmi
+uiBezierPath.cmo: wrapper.cmi cocoa.cmi uiBezierPath.cmi
+uiBezierPath.cmx: wrapper.cmx cocoa.cmx uiBezierPath.cmi
+uiFont.cmo: wrapper.cmi uiFont.cmi
+uiFont.cmx: wrapper.cmx uiFont.cmi
+uiKit.cmo: uiFont.cmi cocoa.cmi uiKit.cmi
+uiKit.cmx: uiFont.cmx cocoa.cmx uiKit.cmi
+uiView.cmo: wrapper.cmi cocoa.cmi uiView.cmi
+uiView.cmx: wrapper.cmx cocoa.cmx uiView.cmi
+vorocells.cmo: cocoa.cmi vorocells.cmi
+vorocells.cmx: cocoa.cmx vorocells.cmi
+voronoictlr.cmo: wrappee.cmi vorocells.cmi uiView.cmi uiKit.cmi \
+ uiBezierPath.cmi uiApplication.cmi uiActionSheet.cmi colorfield.cmi \
+ cocoa.cmi bzpdraw.cmi bzpdata.cmi
+voronoictlr.cmx: wrappee.cmx vorocells.cmx uiView.cmx uiKit.cmx \
+ uiBezierPath.cmx uiApplication.cmx uiActionSheet.cmx colorfield.cmx \
+ cocoa.cmx bzpdraw.cmx bzpdata.cmx
+wrappee.cmo: wrappee.cmi
+wrappee.cmx: wrappee.cmi
+wrapper.cmo: wrapper.cmi
+wrapper.cmx: wrapper.cmi
+bzpdata.cmi: cocoa.cmi
+bzpdraw.cmi: uiBezierPath.cmi cocoa.cmi
+cocoa.cmi:
+colorfield.cmi: uiKit.cmi cocoa.cmi
+uiActionSheet.cmi: wrapper.cmi uiView.cmi
+uiApplication.cmi: wrapper.cmi
+uiBezierPath.cmi: wrapper.cmi cocoa.cmi
+uiFont.cmi: wrapper.cmi
+uiKit.cmi: uiFont.cmi cocoa.cmi
+uiView.cmi: wrapper.cmi cocoa.cmi
+vorocells.cmi: cocoa.cmi
+wrappee.cmi:
+wrapper.cmi:
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..c6d93c8
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,59 @@
+PLAT = /Developer/Platforms/iPhoneSimulator.platform
+SDK = /Developer/SDKs/iPhoneSimulator4.2.sdk
+PLATAPPS = $(PLAT)/Developer/Applications
+OCAMLDIR = /usr/local/ocamlxsim
+OCAMLBINDIR = $(OCAMLDIR)/bin/
+CC = $(PLAT)/Developer/usr/bin/gcc-4.2
+CFLAGS = -arch i386 -isysroot $(PLAT)$(SDK) -gdwarf-2 \
+ -D__IPHONE_OS_VERSION_MIN_REQUIRED=30200 \
+ -isystem $(OCAMLDIR)/lib/ocaml -DCAML_NAME_SPACE
+MFLAGS = -fobjc-legacy-dispatch -fobjc-abi-version=2
+LDFLAGS = -Xlinker -objc_abi_version -Xlinker 2
+
+MOBS = ViewDelegator.o wrap.o main.o
+MLOBS = wrapper.cmx wrappee.cmx cocoa.cmx uiKit.cmx uiFont.cmx \
+ uiBezierPath.cmx uiView.cmx uiActionSheet.cmx uiApplication.cmx \
+ bzpdata.cmx bzpdraw.cmx colorfield.cmx vorocells.cmx voronoictlr.cmx
+
+all: Voronoi Voronoi.nib Info.plist PkgInfo
+
+Voronoi: $(MOBS) $(MLOBS)
+ $(OCAMLBINDIR)ocamlopt -cc '$(CC)' -ccopt '$(CFLAGS)' \
+ -cclib '$(LDFLAGS)' \
+ -o Voronoi \
+ $(MOBS) $(MLOBS) \
+ -cclib '-framework UIKit' \
+ -cclib '-framework Foundation'
+
+execute: all
+ $(PLATAPPS)/iPhone\ Simulator.app/Contents/MacOS/iPhone\ Simulator \
+ -SimulateApplication Voronoi &
+
+Voronoi.nib: Voronoi.xib
+ ibtool --compile Voronoi.nib Voronoi.xib
+
+
+PkgInfo:
+ echo -n 'APPL????' > PkgInfo
+
+clean:
+ rm -rf Voronoi Voronoi.nib PkgInfo build *.o *.cm[iox]
+
+%.o: %.m
+ $(CC) $(CFLAGS) $(MFLAGS) -c $<
+
+%.cmi: %.mli
+ $(OCAMLBINDIR)ocamlc -c $<
+
+%.cmo: %.ml
+ $(OCAMLBINDIR)ocamlc -c $<
+
+%.cmx: %.ml
+ $(OCAMLBINDIR)ocamlopt -cc '$(CC)' -ccopt '$(CFLAGS)' -c $<
+
+depend::
+ $(OCAMLBINDIR)ocamldep *.ml *.mli > MLDepend
+ $(CC) $(CFLAGS) -MM *.m > MDepend
+
+-include MLDepend
+-include MDepend
diff --git a/ViewDelegator.h b/ViewDelegator.h
new file mode 100644
index 0000000..d40326e
--- /dev/null
+++ b/ViewDelegator.h
@@ -0,0 +1,48 @@
+/* ViewDelegator.h UIView subclass to delegate touches, motions, and
+ * drawRect:
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ */
+
+/* Protocol for the delegate.
+ */
+@protocol ViewDelegate
+@optional
+- (BOOL) viewCanBecomeFirstResponder: (UIView *) view;
+
+- (void) view: (UIView *) view
+ touchesBegan: (NSSet *) touches
+ withEvent: (UIEvent *) event;
+- (void) view: (UIView *) view
+ touchesCancelled: (NSSet *) touches
+ withEvent: (UIEvent *) event;
+- (void) view: (UIView *) view
+ touchesEnded: (NSSet *) touches
+ withEvent: (UIEvent *) event;
+- (void) view: (UIView *) view
+ touchesMoved: (NSSet *) touches
+ withEvent: (UIEvent *) event;
+
+- (void) view: (UIView *) view
+ motionBegan: (UIEventSubtype) motion
+ withEvent: (UIEvent *) event;
+- (void) view: (UIView *) view
+ motionCancelled: (UIEventSubtype) motion
+ withEvent: (UIEvent *) event;
+- (void) view: (UIView *) view
+ motionEnded: (UIEventSubtype) motion
+ withEvent: (UIEvent *) event;
+
+- (void) view: (UIView *) view drawRect: (CGRect) rect;
+@end
+
+/* Interface for the delegator.
+ */
+@interface ViewDelegator : UIView
+{
+ NSObject *delegate;
+}
+@property(nonatomic, assign) IBOutlet NSObject *delegate;
+@end
diff --git a/ViewDelegator.m b/ViewDelegator.m
new file mode 100644
index 0000000..1f972a6
--- /dev/null
+++ b/ViewDelegator.m
@@ -0,0 +1,93 @@
+/* ViewDelegator.m UIView subclass to delegate touches, motions, and
+ * drawRect:
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *
+ * This code is logically a small extension of Cocoa Touch. It doesn't
+ * need to know anything about OCaml.
+ */
+#import
+
+#import "ViewDelegator.h"
+
+@implementation ViewDelegator
+
+@dynamic delegate;
+
+- (NSObject *) delegate
+{
+ return delegate;
+}
+
+
+- (void) setDelegate: (NSObject *) aDelegate
+{
+ delegate = aDelegate;
+}
+
+- (BOOL) canBecomeFirstResponder
+{
+ if([delegate respondsToSelector: @selector(viewCanBecomeFirstResponder:)])
+ return [delegate viewCanBecomeFirstResponder: self];
+ return [super canBecomeFirstResponder];
+}
+
+- (void) touchesBegan: (NSSet *) touches withEvent: (UIEvent *) event
+{
+ if([delegate respondsToSelector: @selector(view:touchesBegan:withEvent:)])
+ [delegate view: self touchesBegan: touches withEvent: event];
+}
+
+
+- (void) touchesMoved: (NSSet *) touches withEvent: (UIEvent *) event
+{
+ if([delegate respondsToSelector: @selector(view:touchesMoved:withEvent:)])
+ [delegate view: self touchesMoved: touches withEvent: event];
+}
+
+
+- (void) touchesEnded: (NSSet *) touches withEvent: (UIEvent *) event
+{
+ if([delegate respondsToSelector: @selector(view:touchesEnded:withEvent:)])
+ [delegate view: self touchesEnded: touches withEvent: event];
+}
+
+
+- (void) touchesCancelled: (NSSet *) touches withEvent: (UIEvent *) event
+{
+ if([delegate respondsToSelector:
+ @selector(view:touchesCancelled:withEvent:)])
+ [delegate view: self touchesCancelled: touches withEvent: event];
+}
+
+
+- (void) motionBegan: (UIEventSubtype) motion withEvent: (UIEvent *) event
+{
+ if([delegate respondsToSelector: @selector(view:motionBegan:withEvent:)])
+ [delegate view: self motionBegan: motion withEvent: event];
+}
+
+
+- (void) motionCancelled: (UIEventSubtype) motion withEvent: (UIEvent *) event
+{
+ if([delegate respondsToSelector:
+ @selector(view:motionCancelled:withEvent:)])
+ [delegate view: self motionCancelled: motion withEvent: event];
+}
+
+
+- (void) motionEnded: (UIEventSubtype) motion withEvent: (UIEvent *) event
+{
+ if([delegate respondsToSelector: @selector(view:motionEnded:withEvent:)])
+ [delegate view: self motionEnded: motion withEvent: event];
+}
+
+
+- (void) drawRect: (CGRect) rect
+{
+ if([delegate respondsToSelector: @selector(view:drawRect:)])
+ [delegate view: self drawRect: rect];
+}
+@end
diff --git a/Voronoi.xcodeproj/project.pbxproj b/Voronoi.xcodeproj/project.pbxproj
new file mode 100644
index 0000000..fadd3f9
--- /dev/null
+++ b/Voronoi.xcodeproj/project.pbxproj
@@ -0,0 +1,80 @@
+// !$*UTF8*$!
+{
+ archiveVersion = 1;
+ classes = {
+ };
+ objectVersion = 46;
+ objects = {
+
+/* Begin PBXFileReference section */
+ 1AB4C0E813A81D82006FC1F5 /* Voronoi.xib */ = {isa = PBXFileReference; lastKnownFileType = file.xib; path = Voronoi.xib; sourceTree = ""; };
+ 1AB4C0E913A81F7A006FC1F5 /* ViewDelegator.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = ViewDelegator.h; sourceTree = ""; };
+ 1AB4C0EA13A81F7A006FC1F5 /* ViewDelegator.m */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.objc; path = ViewDelegator.m; sourceTree = ""; };
+ 1AB4C0EB13A82441006FC1F5 /* wrap.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = wrap.h; sourceTree = ""; };
+ 1AB4C0EC13A82441006FC1F5 /* wrap.m */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.objc; path = wrap.m; sourceTree = ""; };
+/* End PBXFileReference section */
+
+/* Begin PBXGroup section */
+ 1AB4C0DF13A81B48006FC1F5 = {
+ isa = PBXGroup;
+ children = (
+ 1AB4C0E813A81D82006FC1F5 /* Voronoi.xib */,
+ 1AB4C0EB13A82441006FC1F5 /* wrap.h */,
+ 1AB4C0EC13A82441006FC1F5 /* wrap.m */,
+ 1AB4C0E913A81F7A006FC1F5 /* ViewDelegator.h */,
+ 1AB4C0EA13A81F7A006FC1F5 /* ViewDelegator.m */,
+ );
+ sourceTree = "";
+ };
+/* End PBXGroup section */
+
+/* Begin PBXProject section */
+ 1AB4C0E113A81B48006FC1F5 /* Project object */ = {
+ isa = PBXProject;
+ attributes = {
+ LastUpgradeCheck = 0420;
+ };
+ buildConfigurationList = 1AB4C0E413A81B48006FC1F5 /* Build configuration list for PBXProject "Voronoi" */;
+ compatibilityVersion = "Xcode 3.2";
+ developmentRegion = English;
+ hasScannedForEncodings = 0;
+ knownRegions = (
+ en,
+ );
+ mainGroup = 1AB4C0DF13A81B48006FC1F5;
+ projectDirPath = "";
+ projectRoot = "";
+ targets = (
+ );
+ };
+/* End PBXProject section */
+
+/* Begin XCBuildConfiguration section */
+ 1AB4C0E613A81B48006FC1F5 /* Debug */ = {
+ isa = XCBuildConfiguration;
+ buildSettings = {
+ };
+ name = Debug;
+ };
+ 1AB4C0E713A81B48006FC1F5 /* Release */ = {
+ isa = XCBuildConfiguration;
+ buildSettings = {
+ };
+ name = Release;
+ };
+/* End XCBuildConfiguration section */
+
+/* Begin XCConfigurationList section */
+ 1AB4C0E413A81B48006FC1F5 /* Build configuration list for PBXProject "Voronoi" */ = {
+ isa = XCConfigurationList;
+ buildConfigurations = (
+ 1AB4C0E613A81B48006FC1F5 /* Debug */,
+ 1AB4C0E713A81B48006FC1F5 /* Release */,
+ );
+ defaultConfigurationIsVisible = 0;
+ defaultConfigurationName = Release;
+ };
+/* End XCConfigurationList section */
+ };
+ rootObject = 1AB4C0E113A81B48006FC1F5 /* Project object */;
+}
diff --git a/Voronoi.xcodeproj/project.xcworkspace/contents.xcworkspacedata b/Voronoi.xcodeproj/project.xcworkspace/contents.xcworkspacedata
new file mode 100644
index 0000000..11daacc
--- /dev/null
+++ b/Voronoi.xcodeproj/project.xcworkspace/contents.xcworkspacedata
@@ -0,0 +1,7 @@
+
+
+
+
+
diff --git a/Voronoi.xcodeproj/project.xcworkspace/xcuserdata/leo.xcuserdatad/UserInterfaceState.xcuserstate b/Voronoi.xcodeproj/project.xcworkspace/xcuserdata/leo.xcuserdatad/UserInterfaceState.xcuserstate
new file mode 100644
index 0000000..a5fcdfb
Binary files /dev/null and b/Voronoi.xcodeproj/project.xcworkspace/xcuserdata/leo.xcuserdatad/UserInterfaceState.xcuserstate differ
diff --git a/Voronoi.xcodeproj/xcuserdata/leo.xcuserdatad/xcschemes/iOS.xcscheme b/Voronoi.xcodeproj/xcuserdata/leo.xcuserdatad/xcschemes/iOS.xcscheme
new file mode 100644
index 0000000..78a8ffc
--- /dev/null
+++ b/Voronoi.xcodeproj/xcuserdata/leo.xcuserdatad/xcschemes/iOS.xcscheme
@@ -0,0 +1,41 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/Voronoi.xcodeproj/xcuserdata/leo.xcuserdatad/xcschemes/xcschememanagement.plist b/Voronoi.xcodeproj/xcuserdata/leo.xcuserdatad/xcschemes/xcschememanagement.plist
new file mode 100644
index 0000000..dd7132d
--- /dev/null
+++ b/Voronoi.xcodeproj/xcuserdata/leo.xcuserdatad/xcschemes/xcschememanagement.plist
@@ -0,0 +1,14 @@
+
+
+
+
+ SchemeUserState
+
+ iOS.xcscheme
+
+ orderHint
+ 0
+
+
+
+
diff --git a/Voronoi.xib b/Voronoi.xib
new file mode 100644
index 0000000..0f5f989
--- /dev/null
+++ b/Voronoi.xib
@@ -0,0 +1,261 @@
+
+
+
+ 1056
+ 10J869
+ 1306
+ 1038.35
+ 461.00
+
+
+
+
+
+ YES
+
+ IBFilesOwner
+ IBCocoaTouchFramework
+
+
+ IBFirstResponder
+ IBCocoaTouchFramework
+
+
+ IBCocoaTouchFramework
+
+
+
+ 1316
+
+ YES
+
+
+ 1298
+ {{0, 20}, {320, 460}}
+
+
+
+
+ 3
+ MQA
+
+ 2
+
+
+ IBCocoaTouchFramework
+
+
+
+ {320, 480}
+
+
+
+
+ 1
+ MSAxIDEAA
+
+ NO
+ NO
+
+ IBCocoaTouchFramework
+ YES
+ YES
+
+
+
+
+ YES
+
+
+ delegate
+
+
+
+ 5
+
+
+
+ delegator
+
+
+
+ 8
+
+
+
+ delegate
+
+
+
+ 9
+
+
+
+
+ YES
+
+ 0
+
+
+
+
+
+ 2
+
+
+ YES
+
+
+
+
+
+ -1
+
+
+ File's Owner
+
+
+ 4
+
+
+ Voronoictlr
+
+
+ -2
+
+
+
+
+ 7
+
+
+
+
+
+
+ YES
+
+ YES
+ -1.CustomClassName
+ -2.CustomClassName
+ 2.IBAttributePlaceholdersKey
+ 2.IBEditorWindowLastContentRect
+ 2.IBPluginDependency
+ 2.UIWindow.visibleAtLaunch
+ 4.CustomClassName
+ 4.IBPluginDependency
+ 7.CustomClassName
+ 7.IBPluginDependency
+
+
+ YES
+ UIApplication
+ UIResponder
+
+ YES
+
+
+
+ {{341, 676}, {320, 480}}
+ com.apple.InterfaceBuilder.IBCocoaTouchPlugin
+
+ Voronoictlr
+ com.apple.InterfaceBuilder.IBCocoaTouchPlugin
+ ViewDelegator
+ com.apple.InterfaceBuilder.IBCocoaTouchPlugin
+
+
+
+ YES
+
+
+
+
+
+ YES
+
+
+
+
+ 9
+
+
+
+ YES
+
+ ViewDelegator
+ UIView
+
+ delegate
+ NSObject
+
+
+ delegate
+
+ delegate
+ NSObject
+
+
+
+ IBProjectSource
+ ./Classes/ViewDelegator.h
+
+
+
+ Voronoictlr
+ WrapOCaml
+
+ delegator
+ UIView
+
+
+ delegator
+
+ delegator
+ UIView
+
+
+
+ IBProjectSource
+ ./Classes/Voronoictlr.h
+
+
+
+ WrapOCaml
+ NSObject
+
+ IBProjectSource
+ ./Classes/WrapOCaml.h
+
+
+
+
+ 0
+ IBCocoaTouchFramework
+
+ com.apple.InterfaceBuilder.CocoaTouchPlugin.InterfaceBuilder3
+
+
+ YES
+ 3
+ 301
+
+
diff --git a/bzpdata.ml b/bzpdata.ml
new file mode 100644
index 0000000..b9fdfa4
--- /dev/null
+++ b/bzpdata.ml
@@ -0,0 +1,118 @@
+(* bzpdata.ml Represent Bezier paths as data
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+type bzp_elem =
+| BZMove of Cocoa.point
+| BZLine of Cocoa.point
+| BZCurve of Cocoa.point * Cocoa.point * Cocoa.point (* Cp1 Cp2 Endp *)
+| BZClose
+
+type bzpath = bzp_elem list
+
+(* A graphically interesting figure.
+ *)
+let figure1 = [
+ BZMove (178.887, 137.734);
+ BZCurve ((197.923, 137.734), (212.375, 140.954), (222.244, 147.393));
+ BZCurve ((232.112, 153.831), (238.691, 161.670), (241.980, 170.908));
+ BZCurve ((245.269, 180.147), (247.404, 195.544), (248.384, 217.100));
+ BZCurve ((249.364, 241.035), (254.718, 258.847), (264.446, 270.535));
+ BZCurve ((274.174, 282.223), (290.166, 288.066), (312.422, 288.066));
+ BZLine (312.422, 280.088);
+ BZCurve ((304.443, 279.528), (299.019, 276.414), (296.150, 270.745));
+ BZCurve ((293.280, 265.076), (291.846, 253.073), (291.846, 234.736));
+ BZCurve ((291.846, 207.861), (289.011, 187.110), (283.342, 172.483));
+ BZCurve ((277.673, 157.856), (266.301, 145.993), (249.224, 136.895));
+ BZCurve ((232.147, 127.796), (208.701, 122.897), (178.887, 122.197));
+ BZLine (178.887, 55.640);
+ BZCurve ((178.887, 39.263), (179.832, 28.660), (181.721, 23.831));
+ BZCurve ((183.611, 19.001), (187.600, 15.117), (193.689, 12.178));
+ BZCurve ((199.778, 9.238), (209.191, 7.769), (221.929, 7.769));
+ BZLine (221.929, 0.000);
+ BZLine ( 95.532, 0.000);
+ BZLine ( 95.532, 7.769);
+ BZCurve ((107.990, 7.909), (117.263, 9.273), (123.352, 11.863));
+ BZCurve ((129.441, 14.452), (133.500, 18.232), (135.530, 23.201));
+ BZCurve ((137.559, 28.170), (138.574, 38.983), (138.574, 55.640));
+ BZLine (138.574, 122.197);
+ BZCurve ((108.480, 122.897), ( 85.104, 127.726), ( 68.447, 136.685));
+ BZCurve (( 51.790, 145.643), ( 40.487, 157.366), ( 34.539, 171.853));
+ BZCurve (( 28.590, 186.340), ( 25.615, 207.371), ( 25.615, 234.946));
+ BZCurve (( 25.615, 252.583), ( 24.285, 264.306), ( 21.626, 270.115));
+ BZCurve (( 18.966, 275.924), ( 13.438, 279.248), ( 5.039, 280.088));
+ BZLine ( 5.039, 288.066);
+ BZCurve (( 19.177, 287.786), ( 30.584, 285.547), ( 39.263, 281.348));
+ BZCurve (( 47.941, 277.148), ( 54.905, 269.730), ( 60.154, 259.092));
+ BZCurve (( 65.403, 248.454), ( 68.377, 234.456), ( 69.077, 217.100));
+ BZCurve (( 70.057, 195.683), ( 72.122, 180.356), ( 75.271, 171.118));
+ BZCurve (( 78.420, 161.880), ( 85.034, 154.006), ( 95.112, 147.498));
+ BZCurve ((105.190, 140.989), (119.678, 137.734), (138.574, 137.734));
+ BZLine (138.574, 229.277);
+ BZCurve ((138.574, 245.654), (137.629, 256.257), (135.740, 261.086));
+ BZCurve ((133.850, 265.916), (129.896, 269.730), (123.877, 272.529));
+ BZCurve ((117.858, 275.329), (108.410, 276.799), ( 95.532, 276.938));
+ BZLine ( 95.532, 284.707);
+ BZLine (221.929, 284.707);
+ BZLine (221.929, 276.938);
+ BZCurve ((209.051, 276.799), (199.603, 275.364), (193.584, 272.634));
+ BZCurve ((187.565, 269.905), (183.611, 266.091), (181.721, 261.191));
+ BZCurve ((179.832, 256.292), (178.887, 245.654), (178.887, 229.277));
+ BZClose;
+ (* BZMove (317.251, 0.000); *)
+]
+
+
+let bbox bzpath =
+ (* Return bounding box for the path. We assume the path starts with
+ * BZMove (so initial position is immaterial) and that its curves
+ * aren't too erratic (they stay inside the rectangle bounded by
+ * start and end points). These are true for the paths we work with
+ * here.
+ *)
+ let bbmax (xmin, xmax, ymin, ymax as bb) elem =
+ match elem with
+ | BZMove (x, y)
+ | BZLine (x, y)
+ | BZCurve (_, _, (x, y)) ->
+ (min x xmin, max x xmax, min y ymin, max y ymax)
+ | _ -> bb
+ in let (xmin, xmax, ymin, ymax) =
+ List.fold_left bbmax (1_000_000.0, 0.0, 1_000_000.0, 0.0) bzpath
+ in
+ (xmin, ymin, xmax -. xmin, ymax -. ymin)
+
+
+let bzp_scale bzpath (x, y, w, h) =
+ let (bx, by, bw, bh) = bbox bzpath
+ in let s, tx, ty =
+ if (w /. bw) < (h /. bh) then
+ let s = w /. bw
+ in let tx = x -. s *. bx
+ in let ty = y -. s *. by -. (s *. bh -. h) /. 2.0
+ in
+ s, tx, ty
+ else
+ let s = h /. bh
+ in let tx = x -. s *. bx -. (s *. bw -. w) /. 2.0
+ in let ty = y +. h -. s *. (by +. bh)
+ in
+ s, tx, ty
+ in let fx x = s *. x +. tx
+ in let fy y = s *. (by +. by +. bh -. y) +. ty
+ in let fp (x, y) = (fx x, fy y)
+ in let felem elem =
+ match elem with
+ | BZMove p -> BZMove (fp p)
+ | BZLine p -> BZLine (fp p)
+ | BZCurve (c1, c2, p) -> BZCurve (fp c1, fp c2, fp p)
+ | _ -> elem
+ in
+ List.map felem bzpath
+
+
+let bzp_iter efun bzpath =
+ List.iter efun bzpath
diff --git a/bzpdata.mli b/bzpdata.mli
new file mode 100644
index 0000000..c3013b7
--- /dev/null
+++ b/bzpdata.mli
@@ -0,0 +1,26 @@
+(* bzpdata.mli Represent Bezier paths as data
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+type bzp_elem =
+| BZMove of Cocoa.point
+| BZLine of Cocoa.point
+| BZCurve of Cocoa.point * Cocoa.point * Cocoa.point
+| BZClose
+
+type bzpath = bzp_elem list
+
+(* A graphically interesting figure.
+ *)
+val figure1 : bzpath
+
+(* Scale and translate the figure to fit in the given rectangle.
+ *)
+val bzp_scale : bzpath -> Cocoa.rect -> bzpath
+
+(* Call the function for each element of the figure.
+ *)
+val bzp_iter : (bzp_elem -> unit) -> bzpath -> unit
diff --git a/bzpdraw.ml b/bzpdraw.ml
new file mode 100644
index 0000000..47b7530
--- /dev/null
+++ b/bzpdraw.ml
@@ -0,0 +1,33 @@
+(* bzpdraw.ml Drawing primitives for Bezier paths
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+(* Value for best Bezier approximation of quarter circle.
+ *)
+let qcK = (4.0 /. 3.0) *. (sqrt 2.0 -. 1.0)
+
+let add_circle (bzp: UiBezierPath.t) (center: Cocoa.point) (r: float) =
+ (* Add a circle to the given Bezier path, with the given center and
+ * radius. The circle is added as a closed subpath. The current
+ * point afterwards is at (cx + r, cy), the rightmost point of the
+ * circle.
+ *)
+ let (cx, cy) = center
+ in let quarter_circle (ux, uy) =
+ (* u is the initial tangent unit vector (here always parallel to
+ * an axis). Caller is responsible for setting current point.
+ *)
+ bzp#addCurveToPoint'controlPoint1'controlPoint2'
+ (cx +. r *. ux, cy +. r *. uy)
+ (cx +. r *. (qcK *. ux +. uy), cy +. r *. (qcK *. uy -. ux))
+ (cx +. r *. (ux +. qcK *. uy), cy +. r *. (uy -. qcK *. ux))
+ in
+ begin
+ bzp#moveToPoint' (cx +. r, cy);
+ List.iter quarter_circle
+ [ (0.0, 1.0); (-1.0, 0.0); (0.0, -1.0); (1.0, 0.0) ];
+ bzp#closePath;
+ end
diff --git a/bzpdraw.mli b/bzpdraw.mli
new file mode 100644
index 0000000..396a103
--- /dev/null
+++ b/bzpdraw.mli
@@ -0,0 +1,12 @@
+(* bzpdraw.mli Drawing primitives for Bezier paths
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+(* Draw an approximation of a circle using Bezier curves. In iOS 4.0
+ * there is a general UIBezierPath method for drawing circular arcs, but
+ * it might be nice to support earlier versions.
+ *)
+val add_circle : UiBezierPath.t -> Cocoa.point -> float -> unit
diff --git a/cocoa.ml b/cocoa.ml
new file mode 100644
index 0000000..da869f7
--- /dev/null
+++ b/cocoa.ml
@@ -0,0 +1,22 @@
+(* cocoa.ml Shared Cocoa Touch definitions
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+type point = float * float
+type size = float * float
+type rect = float * float * float * float
+
+let pi = 4.0 *. atan 1.0
+let frnd f = floor (f +. 0.5)
+let irnd f = int_of_float (frnd f)
+let sqr x = x *. x
+let dist2 (a, b) (c, d) = sqr (c -. a) +. sqr (d -. b)
+let dist p1 p2 = sqrt (dist2 p1 p2)
+
+let normal s m =
+ let u, v = Random.float 1.0, Random.float 1.0
+ in let n = sqrt (-2.0 *. log u) *. cos (2.0 *. pi *. v)
+ in
+ s *. n +. m
diff --git a/cocoa.mli b/cocoa.mli
new file mode 100644
index 0000000..b4734a1
--- /dev/null
+++ b/cocoa.mli
@@ -0,0 +1,23 @@
+(* cocoa.mli Shared Cocoa Touch definitions
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+(* Many of the primitive types are most naturally handled as OCaml
+ * tuples. Even in Cocoa they are immutable.
+ *)
+type point = float * float (* x, y *)
+type size = float * float (* w, h *)
+type rect = float * float * float * float (* x, y, w, h *)
+
+(* Also, some useful shared definitions (not so Cocoa-ish).
+ *)
+val pi : float
+val frnd : float -> float
+val irnd : float -> int
+val sqr : float -> float
+val dist2 : point -> point -> float (* Square of Euclidean distance *)
+val dist : point -> point -> float (* Euclidean distance *)
+val normal : float -> float -> float (* Sample from normal distribution *)
diff --git a/colorfield.ml b/colorfield.ml
new file mode 100644
index 0000000..e21c1df
--- /dev/null
+++ b/colorfield.ml
@@ -0,0 +1,404 @@
+(* colorfield.ml Assign an interesting color to every point in a
+ * rectangle
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+(* This implementation is based on second-order Voronoi diagrams: given
+ * a small set of colored sites, the color of each point is a blend of
+ * the colors of the two nearest sites.
+ *)
+
+let modf a b =
+ (* More "mathematical" mod than mod_float. Answer is always
+ * non-negative, rather than having the sign of a.
+ *)
+ if a >= 0.0 then mod_float a b (* Possibly faster *)
+ else a -. floor (a /. b) *. b
+
+type hsla = float * float * float * float
+
+(* The internal state uses a modified HSL where the hues are taken from
+ * the Itten color wheel (Johannes Itten, 1961). People (in my part of
+ * the world) seem to be used to seeing color schemes based on it.
+ *)
+type itten = float * float * float * float
+
+
+(* Color utilities.
+ *)
+let hsva_of_rgba (r, g, b, a) =
+ (* From wikipedia, "HSL and HSV".
+ *)
+ let max = max (max r g) b
+ in let min = min (min r g) b
+ in let c = max -. min
+ in let h' =
+ if c < 0.004 then 0.0 (* Grayscale, no hue *)
+ else if max = r then modf ((g -. b) /. c) 6.0
+ else if max = g then ((b -. r) /. c) +. 2.0
+ else ((r -. g) /. c) +. 4.0
+ in let h = h' *. 60.0
+ in let v = max
+ in let s = if v < 0.004 then 0.0 else c /. v
+ in
+ (h, s, v, a)
+
+
+let rgba_of_hsla (h, s, l, a) =
+ (* From wikipedia, "HSL and HSV".
+ *)
+ let c = (1.0 -. abs_float (2.0 *. l -. 1.0)) *. s
+ in let h' = h /. 60.0
+ in let x = c *. (1.0 -. abs_float (mod_float h' 2.0 -. 1.0))
+ in let r, g, b =
+ if h' >= 0.0 && h' < 1.0 then c, x, 0.0
+ else if h' >= 1.0 && h' < 2.0 then x, c, 0.0
+ else if h' >= 2.0 && h' < 3.0 then 0.0, c, x
+ else if h' >= 3.0 && h' < 4.0 then 0.0, x, c
+ else if h' >= 4.0 && h' < 5.0 then x, 0.0, c
+ else c, 0.0, x
+ in let m = l -. 0.5 *. c
+ in
+ (r +. m, g +. m, b +. m, a)
+
+
+let hsla_interpolate (hsla1: hsla) (hsla2: hsla) f =
+ (* Interpolate between the two HSLA values, for making a gradient.
+ * f is a value between 0 and 1. We use this for Itten values,
+ * which also works: basically you just need a system based on
+ * cylindrical coordinates.
+ *)
+ let to_cartesian (deg, r, z, a) =
+ let th = deg *. Cocoa.pi /. 180.0
+ in
+ (r *. cos th, r *. sin th, z, a)
+ in let to_cylindrical (x, y, z, a) =
+ let th = atan2 y x
+ in let th' = if th < 0.0 then th +. 2.0 *. Cocoa.pi else th
+ in
+ (th' *. 180.0 /. Cocoa.pi, sqrt (x *. x +. y *. y), z, a)
+ in let interp1 a b = a +. f *. (b -. a)
+ in let (x1, y1, z1, a1) = to_cartesian hsla1
+ in let (x2, y2, z2, a2) = to_cartesian hsla2
+ in let xyza =
+ (interp1 x1 x2, interp1 y1 y2, interp1 z1 z2, interp1 a1 a2)
+ in
+ to_cylindrical xyza
+
+
+(* As noted above, the field is calculated from a small set of Voronoi
+ * sites with associated colors. Some fields have an inscribed figure.
+ * Currently it's a character, but it could be any figure with an inside
+ * and outside.
+ *
+ * We're going to calculate the figure on demand (so we can do some
+ * caching). Since the figure is always the same (right now), we just
+ * need to remember the color and the size.
+ *)
+type site = (itten * Cocoa.point)
+let itten_of = fst
+let point_of = snd
+
+type field =
+| FSimple of site list
+| FFigured of itten * Cocoa.size * site list
+| FFiguredo of itten * Cocoa.size * itten * site list
+
+
+let itten_reflight hue =
+ (* The Itten color wheel has lightnesses that give an evenness in
+ * human perception. Return the reference lightness level for a
+ * given hue.
+ *)
+ let a = mod_float hue 360.0
+ in
+ if a <= 30.0 then 0.000333333 *. a +. 0.51
+ else if a <= 60.0 then 0.000333333 *. a +. 0.51
+ else if a <= 90.0 then -0.000666667 *. a +. 0.57
+ else if a <= 120.0 then -0.001 *. a +. 0.6
+ else if a <= 150.0 then -0.00133333 *. a +. 0.64
+ else if a <= 180.0 then -0.00533333 *. a +. 1.24
+ else if a <= 210.0 then 0.00333333 *. a -. 0.32
+ else if a <= 240.0 then 0.00166667 *. a +. 0.03
+ else if a <= 270.0 then 0.0 *. a +. 0.43
+ else if a <= 300.0 then -0.00133333 *. a +. 0.79
+ else if a <= 330.0 then 0.0 *. a +. 0.39
+ else 0.004 *. a -. 0.93
+
+
+let hsl_hue_of_itten hue =
+ (* Color schemes are very commonly described in terms of the Itten
+ * color wheel (Johannes Itten, 1961). Translate from an Itten hue
+ * to an HSL hue, where both are expressed as an angle from 0 to
+ * 360.
+ *)
+ let a = mod_float hue 360.0
+ in
+ if a <= 30.0 then 0.666667 *. a
+ else if a <= 60.0 then 0.4 *. a +. 8.0
+ else if a <= 90.0 then 0.466667 *. a +. 4.0
+ else if a <= 120.0 then 0.333333 *. a +. 16.0
+ else if a <= 150.0 then 0.766667 *. a -. 36.0
+ else if a <= 180.0 then 2.63333 *. a -. 316.0
+ else if a <= 210.0 then 1.13333 *. a -. 46.0
+ else if a <= 240.0 then 0.533333 *. a +. 80.0
+ else if a <= 270.0 then 0.833333 *. a +. 8.0
+ else if a <= 300.0 then 1.5 *. a -. 172.0
+ else if a <= 330.0 then 1.46667 *. a -. 162.0
+ else 1.26667 *. a -. 96.0
+
+
+let hsla_of_itten (h, s, l, a) =
+ (hsl_hue_of_itten h, s, l, a)
+
+
+let rgba_of_itten hsla =
+ rgba_of_hsla (hsla_of_itten hsla)
+
+
+let itten_contrast hsla1 hsla2 : float =
+ (* Calculate a (very) crude measure of the contrast between the two
+ * colors. We just use the distance in RGB space, which is very
+ * weakly correlated with perception. That's why it's crude. The
+ * result is a number between 0.0 (same color) and sqrt 3.0 (the
+ * distance between white and black, red and cyan, etc.).
+ *)
+ let sqr = Cocoa.sqr (* Convenient abbreviation *)
+ in let (r1, g1, b1, _) = rgba_of_itten hsla1
+ in let (r2, g2, b2, _) = rgba_of_itten hsla2
+ in
+ sqrt (sqr (r2 -. r1) +. sqr (g2 -. g1) +. sqr (b2 -. b1))
+
+
+let uikit_of_itten hsla =
+ (* Translate Itten variant of HSLA to the HSVA format used by UiKit.
+ * (All returned values are in the range [0..1].)
+ *)
+ let (h, s, v, a) = hsva_of_rgba (rgba_of_hsla (hsla_of_itten hsla))
+ in
+ (h /. 360.0, s, v, a)
+
+
+let scheme_of_base (h, s, l, a) =
+ (* Expand the base color to a color scheme.
+ *)
+ match Random.int 5 with
+ | 0 ->
+ (* Monochrome *)
+ let l1 = mod_float (l +. 0.25) 1.0
+ in let l2 = mod_float (l +. 0.75) 1.0
+ in
+ [| (h, s, l, a); (h, s, l1, a); (h, s, l2, a) |]
+ | 1 ->
+ (* Complement *)
+ let h1 = mod_float (h +. 180.0) 360.0
+ in let l1 = mod_float (l +. 0.20) 1.0
+ in
+ [| (h, s, l, a); (h1, s, l1, a) |]
+ | 2 ->
+ (* Split complement *)
+ let h1 = mod_float (h +. 150.0) 360.0
+ in let h2 = mod_float (h +. 210.0) 360.0
+ in
+ [| (h, s, l, a); (h1, s, l, a); (h2, s, l, a) |]
+ | 3 ->
+ (* Analogous *)
+ let h1 = mod_float (h +. 30.0) 360.0
+ in let h2 = mod_float (h +. 330.0) 360.0
+ in
+ [| (h, s, l, a); (h1, s, l, a); (h2, s, l, a) |]
+ | _ ->
+ (* Tetrad *)
+ let h1 = mod_float (h +. 90.0) 360.0
+ in let l1 = if Random.bool () then l else mod_float (l +. 0.20) 1.0
+ in let h2 = mod_float (h +. 180.0) 360.0
+ in let l2 = if Random.bool () then l else mod_float (l +. 0.80) 1.0
+ in let h3 = mod_float (h +. 270.0) 360.0
+ in let l3 = if Random.bool () then l else mod_float (l +. 0.20) 1.0
+ in
+ [| (h, s, l, a); (h1, s, l1, a); (h2, s, l2, a); (h3, s, l3, a) |]
+
+
+let rec randpts (wd, ht) k =
+ if k <= 0 then
+ []
+ else
+ (Random.float wd, Random.float ht) :: randpts (wd, ht) (k - 1)
+
+
+let itten_perturb (h, s, l, a) =
+ (* Perturb the given color, for variety. Leave the basic hue and
+ * the alpha alone, but possibly change the saturation and
+ * lightness.
+ *)
+ let clamp a = max 0.0 (min 1.0 a)
+ in let s' = if Random.bool () then s else clamp (Cocoa.normal 0.25 s)
+ in let l' = if Random.bool () then l else clamp (Cocoa.normal 0.25 l)
+ in
+ (h, s', l', a)
+
+
+let rec randcolor colors pts =
+ let pick () =
+ itten_perturb colors.(Random.int (Array.length colors))
+ in
+ List.map (fun p -> (pick (), p)) pts
+
+
+let contrasty minc a bs =
+ (* Find a site from the bs that has at least a minimum amount
+ * contrast with a. Return the site and the rest as a pair. If
+ * there is none, return any site. Caller warrants that bs is not
+ * empty.
+ *)
+ let rec go bs accum =
+ match bs with
+ | [] -> (List.hd bs, List.tl bs) (* No contrasty site *)
+ | hd :: tl ->
+ if itten_contrast (itten_of hd) (itten_of a) >= minc then
+ (hd, List.rev_append accum tl)
+ else
+ go tl (hd :: accum)
+ in
+ go bs []
+
+
+let field_make (size: Cocoa.size) (granularity: int) : field =
+ (* Randomly generate a field, i.e., generate the set of colored
+ * points. The granularity parameter controls the size of the
+ * different colored features. In other words, it tells us the
+ * numer of different points to generate.
+ *)
+ let min_ocontrast = 0.2 (* Minimum desired contrast for figure in oval *)
+ in let basehue = Random.float 360.0
+ in let basecolor = (basehue, 1.0, itten_reflight basehue, 1.0)
+ in let scheme = scheme_of_base basecolor
+ in let sites = randcolor scheme (randpts size granularity)
+ in
+ if Random.int 5 = 0 then
+ if Random.int 5 = 0 then
+ match sites with
+ | a :: b :: rest ->
+ let (b', rest') = contrasty min_ocontrast a (b :: rest)
+ in
+ FFiguredo (itten_of a, size, itten_of b', rest')
+ | _ -> FSimple sites (* Too few sites *)
+ else
+ match sites with
+ | a :: rest -> FFigured (itten_of a, size, rest)
+ | _ -> FSimple sites (* Too few sites *)
+ else
+ FSimple sites
+
+
+let g_inside_cache : (Cocoa.size * UiBezierPath.t) option ref = ref None
+
+
+let inside (wd,ht as size) pt =
+ (* Determine whether the point is inside the figure. Currently the
+ * figure is always the same, so we just need to know the size.
+ *)
+ match !g_inside_cache with
+ | Some (csize, cbzp) when csize = size -> cbzp#containsPoint' pt
+ | _ ->
+ let cbzp =
+ match !g_inside_cache with
+ | Some (_, cbzp) -> cbzp
+ | None -> UiBezierPath.bezierPath ()
+ in let rect = (10.0, 10.0, wd -. 20.0, ht -. 20.0)
+ in let sfig = Bzpdata.bzp_scale Bzpdata.figure1 rect
+ in let () =
+ begin
+ cbzp#removeAllPoints;
+ Bzpdata.bzp_iter
+ (fun elem ->
+ match elem with
+ | Bzpdata.BZMove p -> cbzp#moveToPoint' p
+ | Bzpdata.BZLine p -> cbzp#addLineToPoint' p
+ | Bzpdata.BZCurve (cp1, cp2, p) ->
+ cbzp#addCurveToPoint'controlPoint1'controlPoint2'
+ p cp1 cp2
+ | Bzpdata.BZClose ->
+ cbzp#closePath
+ )
+ sfig;
+ g_inside_cache := Some (size, cbzp);
+ end
+ in
+ cbzp#containsPoint' pt
+
+
+let insideo (wd, ht) (x, y) =
+ (* Is the point inside the ellipse of given width and height?
+ *)
+ let x', y' = x -. wd /. 2.0, y -. ht /. 2.0
+ in
+ Cocoa.sqr (ht *. x') +. Cocoa.sqr (wd *. y')
+ <= Cocoa.sqr (0.5 *. ht *. wd)
+
+
+let fract pointa pointb pt =
+ (* What fraction of the way does pt lie between pointa and pointb?
+ * We get our answer by projecting down to the line through the
+ * points. Points on the line outside the segment are handled by
+ * imagining the segment being concatenated to its reflection and
+ * then repeated to infinity. This gives a periodicity twice the
+ * distance from pointa to pointb. (Graphically speaking, it gives
+ * a gradated, striped pattern if pointa and pointb are close to
+ * each other.)
+ *)
+ let da2 = Cocoa.dist2 pointa pt
+ in let db2 = Cocoa.dist2 pointb pt
+ in let dab2 = max 0.1 (Cocoa.dist2 pointa pointb)
+ in let fract = (da2 -. db2 +. dab2) /. (2.0 *. dab2)
+ in let fract = mod_float (abs_float fract) 2.0
+ in
+ if fract > 1.0 then 2.0 -. fract else fract
+
+
+let itten_of_point (f: field) ((x, y) as pt: Cocoa.point) : itten =
+ let dist2_to_pt site =
+ Cocoa.dist2 (point_of site) pt
+ in
+ match f with
+ | FFiguredo (itten, (w, h), _, _)
+ when inside (w -. 20.0, h -. 20.0) (x -. 10.0, y -. 35.0) ->
+ itten
+ | FFigured (itten, size, _) when inside size pt -> itten
+ | FFiguredo (_, size, itten, _) when insideo size pt -> itten
+ | FFiguredo (_, _, _, sites)
+ | FFigured (_, _, sites)
+ | FSimple sites ->
+ (* Find two nearest sites and interpolate between their colors.
+ *)
+ let sosites =
+ List.sort
+ (fun sa sb -> compare (dist2_to_pt sa) (dist2_to_pt sb))
+ sites
+ in
+ match sosites with
+ | [] -> (0.0, 0.0, 0.0, 1.0)
+ | site :: [] -> itten_of site
+ | sitea :: siteb :: _ ->
+ let fr = fract (point_of sitea) (point_of siteb) pt
+ in
+ hsla_interpolate (itten_of sitea) (itten_of siteb) fr
+
+
+let field_value (f: field) (pt: Cocoa.point) : UiKit.color =
+ uikit_of_itten (itten_of_point f pt)
+
+let field_contrast (f: field) (pt: Cocoa.point) (c: float) : UiKit.color =
+ let cadj = min 0.4 (max 0.0 (c /. 2.5))
+ in let (h, s, l, a) = itten_of_point f pt
+ in let l' = if l > 0.6 then l -. cadj else l +. cadj
+ in
+ uikit_of_itten (h, s, l', a)
+
+let field_flatstyle (f: field) =
+ match f with
+ | FFiguredo _ -> true
+ | _ -> false
diff --git a/colorfield.mli b/colorfield.mli
new file mode 100644
index 0000000..0041dff
--- /dev/null
+++ b/colorfield.mli
@@ -0,0 +1,31 @@
+(* colorfield.mli Assign an interesting color to every point in a
+ * rectangle
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+(* Randomly generate colors that make a pleasing combination, and have
+ * mostly smooth gradations between different areas of color.
+ *)
+
+type field
+
+(* Make a field with the given granularity. Granularity specifies the
+ * number of different colored areas, very roughly.
+ *)
+val field_make : Cocoa.size -> int -> field
+
+(* Return the color for the given point.
+ *)
+val field_value : field -> Cocoa.point -> UiKit.color
+
+(* Return a contrasting color for the given point, with a contrast value
+ * from 0 (no contrast) to 1 (high contrast).
+ *)
+val field_contrast : field -> Cocoa.point -> float -> UiKit.color
+
+(* Does the field have fairly wide areas of the same color?
+ *)
+val field_flatstyle : field -> bool
diff --git a/main.m b/main.m
new file mode 100644
index 0000000..5a0d232
--- /dev/null
+++ b/main.m
@@ -0,0 +1,19 @@
+/* main.m Main program of Voronoi example
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *
+ * You can also write the main program in OCaml; just make it the last
+ * module.
+ */
+#import
+
+int main(int argc, char *argv[])
+{
+ NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init];
+ caml_main(argv);
+ int retVal = UIApplicationMain(argc, argv, nil, nil);
+ [pool release];
+ return retVal;
+}
diff --git a/uiActionSheet.ml b/uiActionSheet.ml
new file mode 100644
index 0000000..8bf3c4d
--- /dev/null
+++ b/uiActionSheet.ml
@@ -0,0 +1,60 @@
+(* uiActionSheet.ml Wrapper for Cocoa Touch UIActionSheet
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+class type ['a] _delegate =
+ object method actionSheet'clickedButtonAtIndex' : 'a -> int -> unit end
+
+class type _t =
+ object
+ inherit Wrapper.t
+ method initWithTitle'delegate'cancelButtonTitle'destructiveButtonTitle'otherButtonTitles' :
+ 'a. string option -> (_t #_delegate as 'a) -> string option ->
+ string option -> string list -> _t
+ method initWithTDCDO :
+ 'a. string option -> (_t #_delegate as 'a) -> string option ->
+ string option -> string list -> _t
+ method showInView' : UiView.t -> unit
+ end
+
+external _initWithTDCDO :
+ nativeint -> string option -> _t #_delegate -> string option ->
+ string option -> string list -> _t =
+ "UIActionSheet_initWithTDCDO_bytecode"
+ "UIActionSheet_initWithTDCDO"
+
+external _showInView_ : nativeint -> nativeint -> unit =
+ "UIActionSheet_showInView_"
+
+
+class t (robjcv: nativeint) : _t =
+ object (self)
+ inherit Wrapper.t robjcv
+
+ method initWithTitle'delegate'cancelButtonTitle'destructiveButtonTitle'otherButtonTitles' :
+ 'a. string option -> (_t #_delegate as 'a) -> string option ->
+ string option -> string list -> _t =
+ fun t deleg c d o ->
+ _initWithTDCDO self#contents t deleg c d o
+
+ method initWithTDCDO :
+ 'a. string option -> (_t #_delegate as 'a) -> string option ->
+ string option -> string list -> _t =
+ fun t deleg c d o ->
+ _initWithTDCDO self#contents t deleg c d o
+
+ method showInView' v =
+ _showInView_ self#contents v#contents
+ end
+
+type delegate = t _delegate
+
+(* Create an instance that doesn't wrap an ObjC object. To create a
+ * full fledged instance, (alloc ())#initWithTDCDO ...
+ *)
+let alloc () = new t 0n
+
+let () = Callback.register "UIActionSheet.wrap" (new t)
diff --git a/uiActionSheet.mli b/uiActionSheet.mli
new file mode 100644
index 0000000..c28b0a8
--- /dev/null
+++ b/uiActionSheet.mli
@@ -0,0 +1,31 @@
+(* uiActionSheet.mli Wrapper for Cocoa Touch UIActionSheet
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+class type ['a] _delegate =
+ object method actionSheet'clickedButtonAtIndex' : 'a -> int -> unit end
+
+class t :
+ nativeint ->
+ object
+ inherit Wrapper.t
+
+ method initWithTitle'delegate'cancelButtonTitle'destructiveButtonTitle'otherButtonTitles' :
+ 'a. string option -> (t #_delegate as 'a) -> string option ->
+ string option -> string list -> t
+
+ (* Shorter name for the previous
+ *)
+ method initWithTDCDO :
+ 'a. string option -> (t #_delegate as 'a) -> string option ->
+ string option -> string list -> t
+
+ method showInView' : UiView.t -> unit
+ end
+
+type delegate = t _delegate
+
+val alloc : unit -> t
diff --git a/uiApplication.ml b/uiApplication.ml
new file mode 100644
index 0000000..2085ce9
--- /dev/null
+++ b/uiApplication.ml
@@ -0,0 +1,16 @@
+(* uiApplication.ml Wrapper for Cocoa Touch UIApplication
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+class t robjcv =
+ object (self)
+ inherit Wrapper.t robjcv
+ end
+
+let _ =
+ let wrap robjcv = new t robjcv
+ in
+ Callback.register "UIApplication.wrap" wrap
diff --git a/uiApplication.mli b/uiApplication.mli
new file mode 100644
index 0000000..2a45ffd
--- /dev/null
+++ b/uiApplication.mli
@@ -0,0 +1,10 @@
+(* uiApplication.mli Interface for Cocoa Touch UIApplication
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+class type t =
+object
+ inherit Wrapper.t
+end
diff --git a/uiBezierPath.ml b/uiBezierPath.ml
new file mode 100644
index 0000000..7871fe6
--- /dev/null
+++ b/uiBezierPath.ml
@@ -0,0 +1,58 @@
+(* uiBezierPath.ml Wrapper for Cocoa Touch UIBezierPath
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+external _moveToPoint_ : nativeint -> Cocoa.point -> unit =
+ "UIBezierPath_moveToPoint_"
+external _addLineToPoint_ : nativeint -> Cocoa.point -> unit =
+ "UIBezierPath_addLineToPoint_"
+external _addCurveToPoint_controlPoint1_controlPoint2_ :
+ nativeint -> Cocoa.point -> Cocoa.point -> Cocoa.point -> unit =
+ "UIBezierPath_addCurveToPoint_controlPoint1_controlPoint2_"
+external _closePath : nativeint -> unit =
+ "UIBezierPath_closePath"
+external _removeAllPoints : nativeint -> unit =
+ "UIBezierPath_removeAllPoints"
+
+external _lineWidth : nativeint -> float =
+ "UIBezierPath_lineWidth"
+external _setLineWidth_ : nativeint -> float -> unit =
+ "UIBezierPath_setLineWidth_"
+
+external _fill : nativeint -> unit =
+ "UIBezierPath_fill"
+external _stroke : nativeint -> unit =
+ "UIBezierPath_stroke"
+
+external _containsPoint_ : nativeint -> Cocoa.point -> bool =
+ "UIBezierPath_containsPoint_"
+
+class t robjcv =
+ object (self)
+ inherit Wrapper.t robjcv
+
+ method moveToPoint' p = _moveToPoint_ self#contents p
+ method addLineToPoint' p = _addLineToPoint_ self#contents p
+ method addCurveToPoint'controlPoint1'controlPoint2' p cp1 cp2 =
+ _addCurveToPoint_controlPoint1_controlPoint2_ self#contents p cp1 cp2
+ method closePath = _closePath self#contents
+ method removeAllPoints = _removeAllPoints self#contents
+
+ method lineWidth = _lineWidth self#contents
+ method setLineWidth' = _setLineWidth_ self#contents
+
+ method fill = _fill self#contents
+ method stroke = _stroke self#contents
+
+ method containsPoint' p = _containsPoint_ self#contents p
+ end
+
+let () = Callback.register "UIBezierPath.wrap" (new t)
+
+external bezierPath : unit -> t =
+ "UIBezierPath_bezierPath"
+external bezierPathWithOvalInRect' : Cocoa.rect -> t =
+ "UIBezierPath_bezierPathWithOvalInRect_"
diff --git a/uiBezierPath.mli b/uiBezierPath.mli
new file mode 100644
index 0000000..e5f2557
--- /dev/null
+++ b/uiBezierPath.mli
@@ -0,0 +1,28 @@
+(* uiBezierPath.mli Wrapper for Cocoa Touch UIBezierView
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+class type t =
+object
+ inherit Wrapper.t
+
+ method moveToPoint' : Cocoa.point -> unit
+ method addLineToPoint' : Cocoa.point -> unit
+ method addCurveToPoint'controlPoint1'controlPoint2' :
+ Cocoa.point -> Cocoa.point -> Cocoa.point -> unit
+ method closePath : unit
+ method removeAllPoints : unit
+
+ method lineWidth : float
+ method setLineWidth' : float -> unit
+
+ method fill : unit
+ method stroke : unit
+
+ method containsPoint' : Cocoa.point -> bool
+end
+
+val bezierPath : unit -> t
+val bezierPathWithOvalInRect' : Cocoa.rect -> t
diff --git a/uiFont.ml b/uiFont.ml
new file mode 100644
index 0000000..e53cc83
--- /dev/null
+++ b/uiFont.ml
@@ -0,0 +1,16 @@
+(* uiFont.ml Wrapper for Cocoa Touch UIFont
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+class t robjcv =
+ object (self)
+ inherit Wrapper.t robjcv
+ end
+
+let () = Callback.register "UIFont.wrap" (new t)
+
+external fontWithName'size' : string -> float -> t =
+ "UIFont_fontWithName_size_"
diff --git a/uiFont.mli b/uiFont.mli
new file mode 100644
index 0000000..7ef9d56
--- /dev/null
+++ b/uiFont.mli
@@ -0,0 +1,12 @@
+(* uiFont.mli Wrapper for Cocoa Touch UIFont
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+class type t =
+object
+ inherit Wrapper.t
+end
+
+val fontWithName'size' : string -> float -> t
diff --git a/uiKit.ml b/uiKit.ml
new file mode 100644
index 0000000..2112d3a
--- /dev/null
+++ b/uiKit.ml
@@ -0,0 +1,37 @@
+(* uiKit.ml UiKit functions
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+external rectFill : Cocoa.rect -> unit = "UIKit_RectFill"
+
+type color = float * float * float * float
+
+let (black: color) = (0.0, 0.0, 0.0, 1.0)
+let (white: color) = (0.0, 0.0, 1.0, 1.0)
+let (beige: color) = (0.1167, 0.19, 0.87, 1.0)
+
+external set : color -> unit =
+ "UIKit_set"
+external setFill : color -> unit =
+ "UIKit_setFill"
+external setStroke : color -> unit =
+ "UIKit_setStroke"
+
+external _string_sizeWithFont_ : string -> nativeint -> Cocoa.size =
+ "UIKit_string_sizeWithFont_"
+
+external _string_drawAtPoint_withFont_ :
+ string -> Cocoa.point -> nativeint -> unit =
+ "UIKit_string_drawAtPoint_withFont_"
+
+let string'sizeWithFont' s (f: UiFont.t) =
+ _string_sizeWithFont_ s f#contents
+
+let string'drawAtPoint'withFont' s p (f: UiFont.t) =
+ _string_drawAtPoint_withFont_ s p f#contents
+
+let eventSubtypeNone = 0
+let eventSubtypeMotionShake = 1
diff --git a/uiKit.mli b/uiKit.mli
new file mode 100644
index 0000000..4f42f84
--- /dev/null
+++ b/uiKit.mli
@@ -0,0 +1,33 @@
+(* uiKit.mli UiKit functions
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+val rectFill : Cocoa.rect -> unit
+
+(* In Cocoa this functionality is in UIColor, but I claim colors are
+ * more naturally handled as tuples. They're small and immutable.
+ * Note that these are HSV colors with all three values in [0..1].
+ *)
+type color = float * float * float * float (* h, s, v, a *)
+
+val white: color
+val black: color
+val beige: color
+val set : color -> unit
+val setFill : color -> unit
+val setStroke : color -> unit
+
+(* In Cocoa this functionality is in NSString, but again there are
+ * some advantages to using a lightweight type for strings.
+ *)
+val string'sizeWithFont' : string -> UiFont.t -> Cocoa.size
+val string'drawAtPoint'withFont' : string -> Cocoa.point -> UiFont.t -> unit
+
+(* These belong in UiEvent, but in this simple example we don't wrap
+ * events. So define them here for now.
+ *)
+val eventSubtypeNone : int
+val eventSubtypeMotionShake : int
diff --git a/uiView.ml b/uiView.ml
new file mode 100644
index 0000000..4585c0f
--- /dev/null
+++ b/uiView.ml
@@ -0,0 +1,29 @@
+(* uiView.ml Wrapper for Cocoa Touch UIView
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+external _isFirstResponder : nativeint -> bool =
+ "UIView_isFirstResponder"
+external _becomeFirstResponder : nativeint -> bool =
+ "UIView_becomeFirstResponder"
+external _frame : nativeint -> Cocoa.rect =
+ "UIView_frame"
+external _setNeedsDisplay : nativeint -> unit =
+ "UIView_setNeedsDisplay"
+
+class t robjcv =
+ object (self)
+ inherit Wrapper.t robjcv
+
+ method isFirstResponder = _isFirstResponder self#contents
+ method becomeFirstResponder = _becomeFirstResponder self#contents
+
+ method frame = _frame self#contents
+
+ method setNeedsDisplay = _setNeedsDisplay self#contents
+ end
+
+let () = Callback.register "UIView.wrap" (new t)
diff --git a/uiView.mli b/uiView.mli
new file mode 100644
index 0000000..d597016
--- /dev/null
+++ b/uiView.mli
@@ -0,0 +1,17 @@
+(* uiView.mli Wrapper for Cocoa Touch UIView
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+class type t =
+object
+ inherit Wrapper.t
+
+ method isFirstResponder : bool
+ method becomeFirstResponder : bool
+
+ method frame : Cocoa.rect
+
+ method setNeedsDisplay : unit
+end
diff --git a/vorocells.ml b/vorocells.ml
new file mode 100644
index 0000000..83d75c8
--- /dev/null
+++ b/vorocells.ml
@@ -0,0 +1,215 @@
+(* vorocells.ml Calculate Voronoi cells
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+(* A simple fixed tolerance for FP equality.
+ *)
+let fequal a b = abs_float (a -. b) < 0.000000015
+
+
+(* A polygon is a list of vertices.
+ *)
+type poly = Cocoa.point list
+
+
+(* (a, b, c) denotes the line given by ax + by = c
+ *)
+type line = float * float * float
+
+(* (a, b, c) denotes the halfplane given by ax + by <= c
+ *)
+type hplane = float * float * float
+
+
+let ptonline (a, b, c) (px, py) =
+ (* The point is on the line.
+ *)
+ if fequal c 0.0 then
+ if fequal b 0.0 || fequal py 0.0 then
+ fequal px 0.0
+ else
+ fequal ((-. a *. px) /. (b *. py)) 1.0
+ else
+ fequal ((a *. px +. b *. py) /. c) 1.0
+
+
+let ptinhplane (a, b, c) (px, py) =
+ (* The point is in the halfplane.
+ *)
+ ptonline (a, b, c) (px, py) || a *. px +. b *. py <= c
+
+
+let ptequal (a, b) (c, d) =
+ (* The two points are equal.
+ *)
+ fequal a c && fequal b d
+
+
+let polyinhplane hplane poly =
+ (* The polygon is in the halfplane.
+ *)
+ try
+ let p = List.find (fun p -> not (ptonline hplane p)) poly
+ in
+ ptinhplane hplane p
+ with not_found -> true (* Degenerate poly *)
+
+
+let line_seg_intersect (a, b, c) (px,py as p) (qx,qy as q) =
+ (* If the line intersects the segment at point m, return Some m.
+ * Otherwise return None. By convention, if the segment is
+ * coincident with the line, return Some p. Caller warrants that
+ * the two points are not the same point.
+ *
+ * mx = px + u * (qx - px)
+ * my = py + u * (qy - py)
+ * a * mx + b * my = c
+ *
+ * u = (c - b * py - a * px) / (a * (qx - px) + b * (qy - py))
+ *)
+ let dx, dy = qx -. px, qy -. py
+
+ (* Special case for parallel line and segment.
+ *)
+ in let parallel =
+ if fequal a 0.0 then
+ fequal dy 0.0
+ else if fequal dx 0.0 then
+ fequal b 0.0
+ else
+ fequal ((-. b *. dy) /. (a *. dx)) 1.0
+ in
+ if parallel then
+ if ptonline (a, b, c) p then
+ Some p (* Coincident *)
+ else
+ None (* Non-coincident *)
+ else
+ let u = (c -. b *. py -. a *. px) /. (a *. dx +. b *. dy)
+ in
+ if fequal u 0.0 then
+ Some p
+ else if fequal u 1.0 then
+ Some q
+ else if u >= 0.0 && u <= 1.0 then
+ Some (px +. u *. (qx -. px), py +. u *. (qy -. py))
+ else
+ None (* Outside the segment *)
+
+
+let edge_add chains line p q =
+ (* Process the next edge of a polygon, tracking chains on the two
+ * sides of the given line. If the line intersects the edge at m,
+ * end the current chain at m and start a new chain at m. If it
+ * intersects the middle of the edge, split the edge at m first. If
+ * there's no intersection, just add to current chain.
+ *)
+ let to_cur chains p =
+ match chains with
+ | [] -> [[p]] (* Doesn't actually come up *)
+ | c :: rest -> (p :: c) :: rest
+ in let to_new chains p =
+ [p] :: chains
+ in let chains' = to_cur chains p (* Always goes onto current chain *)
+ in
+ match line_seg_intersect line p q with
+ | None -> chains'
+ | Some m ->
+ if ptequal m p then
+ if ptonline line q then
+ (* Line coincident with edge. Doesn't count as
+ * intersection.
+ *)
+ chains'
+ else
+ (* Intersects at vertex, start new chain.
+ *)
+ to_new chains' p
+ else if ptequal m q then
+ (* Treat edges as half open; i.e., handle vertex q as
+ * part of next edge.
+ *)
+ chains'
+ else
+ (* Split at intersection point.
+ *)
+ to_new (to_cur chains' m) m
+
+
+let poly_line_split poly line : poly * poly =
+ (* The line might split the given convex polygon into two parts, in
+ * which case return them. Otherwise return the original polygon
+ * and an empty polygon.
+ *)
+ match poly with
+ | [] -> ([], [])
+ | p0 :: _ ->
+ let rec findchains chains pts =
+ match pts with
+ | [] ->
+ List.rev_map List.rev chains
+ | p :: [] ->
+ findchains (edge_add chains line p p0) []
+ | p :: (q :: _ as rest) ->
+ findchains (edge_add chains line p q) rest
+ in
+ match findchains [[]] poly with
+ | [s0; s1; s2] -> (s0 @ s2, s1)
+ | _ -> (poly, [])
+
+
+let poly_hplane_intersect poly hplane : poly =
+ (* Intersect the given convex polygon and the given half plane,
+ * giving a new convex polygon (or possibly an empty one).
+ *)
+ let (p1, p2) =
+ match poly_line_split poly hplane with
+ | ([], p) -> (p, []) (* Test the nonempty one if there is one *)
+ | p1p2 -> p1p2
+ in
+ if polyinhplane hplane p1 then p1 else p2
+
+
+let site_site_hplane (a, b) (c, d) =
+ (* Return the halfplane containing (a, b), with its boundary halfway
+ * between (a, b) and (c, d).
+ *)
+ let flip (a, b, c) = (-. a, -. b, -. c)
+ in let hplane =
+ (2.0 *. (c -. a),
+ 2.0 *. (d -. b),
+ c *. c -. a *. a +. d *. d -. b *. b)
+ in
+ if ptinhplane hplane (a, b) then hplane else flip hplane
+
+
+let site_add_edge site cell xsite : poly =
+ (* Site is a Voronoi site with the given cell as calculated so far.
+ * Add an edge to the cell for the given external site and return
+ * the new cell. If xsite isn't close enough to site, it won't
+ * affect the cell shape (no new edge will be added). If xsite is
+ * the same as site, just return the cell.
+ *)
+ if ptequal site xsite then
+ cell
+ else
+ poly_hplane_intersect cell (site_site_hplane site xsite)
+
+
+let cells_make (size: Cocoa.size) (sites: Cocoa.point list) :
+ Cocoa.point list list =
+ (* Calculate the cells for the given Voronoi sites. Return a list
+ * of polygons corresponding to the cells.
+ *)
+ let marg = 10.0
+ in let (wd, ht) = size
+ in let screen =
+ [(-. marg, -. marg); (wd +. marg, -. marg);
+ (wd +. marg, ht +. marg); (-. marg, ht +. marg)]
+ in let make1 site =
+ List.fold_left (site_add_edge site) screen sites
+ in
+ List.map make1 sites
diff --git a/vorocells.mli b/vorocells.mli
new file mode 100644
index 0000000..79e862a
--- /dev/null
+++ b/vorocells.mli
@@ -0,0 +1,7 @@
+(* vorocells.ml Calculate Voronoi cells
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+val cells_make : Cocoa.size -> Cocoa.point list -> Cocoa.point list list
diff --git a/voronoictlr.ml b/voronoictlr.ml
new file mode 100644
index 0000000..3c2cace
--- /dev/null
+++ b/voronoictlr.ml
@@ -0,0 +1,472 @@
+(* voronoictlr.ml Controller for Voronoi example
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+(* If two sites (Voronoi control points) are very close, we merge them
+ * into a single site. However we also track the multiplicity of the
+ * site. So a site is represented as a point and a multiplicity (>= 1)
+ *)
+type site = Cocoa.point * int
+
+let point_of = fst
+let multiplicity_of = snd
+
+
+let central (x, y, w, h) (cx, cy) =
+ (* Determine if the point is in the central part of the rectangle.
+ *)
+ let edgef = 0.5 -. sqrt 2.0 /. 4.0
+ in let edgew = edgef *. w
+ in let edgeh = edgef *.h
+ in
+ cx >= x +. edgew && cx <= x +. w -. edgew &&
+ cy >= y +. edgeh && cy <= y +. h -. edgeh
+
+
+let randcentral (x, y, w, h) =
+ (* Choose a random point in the central part of the rectangle.
+ *)
+ let unscaledr () =
+ 0.5 -. (sqrt 2.0 /. 4.0) +. Random.float (sqrt 2.0 /. 2.0)
+ in
+ (x +. w *. unscaledr (), y +. h *. unscaledr ())
+
+
+let addransites (x, y, w, h) (cx, cy) count sites =
+ (* Add random sites inside the rectangle, concentrated around
+ * the given center.
+ *)
+ let rec pickn tries k accum =
+ (* Don't try more than the given number of times, to guarantee
+ * termination.
+ *)
+ if tries <= 0 || k <= 0 then
+ accum
+ else
+ let theta = Random.float (2.0 *. Cocoa.pi)
+ in let r = abs_float (Cocoa.normal (0.6 *. h) 0.0)
+ in let sx = cx +. r *. sin theta
+ in let sy = cy +. r *. cos theta
+ in let s = (sx, sy)
+ in let tooclose (sp, _) = Cocoa.dist2 sp s < 324.0
+ in
+ if sx < x || sx > x +. w || sy < y || sy > y +. h then
+ pickn (tries - 1) k accum
+ else if List.exists tooclose accum then
+ pickn (tries - 1) k accum
+ else
+ pickn (tries - 1) (k - 1) ((s, 1) :: accum)
+ in
+ pickn (count * 20) count sites
+
+
+let delransites keep_pt count sites =
+ (* Delete the given number of sites at random, preserving any site
+ * at the given point.
+ *)
+ let rec drop k l =
+ if k <= 0 then
+ l
+ else
+ match l with
+ | [] -> []
+ | _ :: tl -> drop (k - 1) tl
+ in let decorate (n, dsites) site =
+ let r = if point_of site = keep_pt then 1 else - Random.bits ()
+ in
+ (n + 1, (r, n, site) :: dsites)
+ in let (sct, dsites) = List.fold_left decorate (0, []) sites
+ in let sodsites =
+ List.sort (fun (b1, _, _) (b2, _, _) -> compare b1 b2) dsites
+ in let sodsites' = drop (min (sct - 1) count) sodsites
+ in let dsites' =
+ List.sort (fun (_, n1, _) (_, n2, _) -> compare n1 n2) sodsites'
+ in
+ List.map (fun (_, _, s) -> s) dsites'
+
+
+class t =
+object (self)
+ inherit Wrappee.t
+
+ (* Soft limit on maximum number of sites. You can exceed this if
+ * you add them one at a time (and there's room for one).
+ *)
+ val max_sites = 180
+
+ (* If you touch this close to an existing site, you move the site
+ * rather than create a new one.
+ *)
+ val touch_radius = 22.0
+
+ (* Two sites that are closer than this are merged into a single
+ * site.
+ *)
+ val ident_radius = 8.0
+
+ (* View that delegates to us. If this fails to show up, check the
+ * NIB file, Voronoi.xib.
+ *)
+ val mutable theDelegator: UiView.t option = None
+
+ (* The current color field, which associates a color with every
+ * point on the screen.
+ *)
+ val mutable colorfield =
+ Colorfield.field_make (10.0, 10.0) 1 (* Temporary initial value *)
+
+ (* Bezier path used for drawing.
+ *)
+ val bezierpath = UiBezierPath.bezierPath ()
+
+ (* The sites of the Voronoi diagram.
+ *)
+ val mutable sites: site list = []
+
+ (* Action sheet for verifying erase.
+ *)
+ val mutable theASheet: UiActionSheet.t option = None
+ val mutable theAdeleg: UiActionSheet.delegate option = None
+
+ (* Accessors.
+ *)
+ method delegator =
+ match theDelegator with
+ | None -> raise Not_found
+ | Some d -> d
+
+ method setDelegator' view =
+ let (_, _, wd, ht) = view#frame
+ in
+ begin
+ Random.self_init ();
+ colorfield <- Colorfield.field_make (wd, ht) 7;
+ theDelegator <- Some view;
+ sites <- [(randcentral (0.0, 0.0, wd, ht), 1)];
+ let adeleg =
+ object
+ method actionSheet'clickedButtonAtIndex' s ix =
+ match ix with
+ | 0 -> (self#back_to_one_dot; self#display)
+ | 1 -> (self#change_colors; self#display)
+ | 2 -> (self#back_to_one_dot; self#change_colors;
+ self#display)
+ | _ -> ()
+ end
+ in let asheet =
+ (UiActionSheet.alloc ())#initWithTDCDO
+ None
+ adeleg
+ (Some "Cancel")
+ None
+ ["Back to One Dot"; "Change Colors"; "Both"]
+ in
+ begin
+ theAdeleg <- Some adeleg;
+ theASheet <- Some asheet;
+ end
+ end
+
+ (* Application state change events.
+ *)
+ method applicationDidFinishLaunching' (app: UiApplication.t) =
+ match theDelegator with
+ | None -> ()
+ | Some view -> ignore view#becomeFirstResponder
+
+ method applicationDidReceiveMemoryWarning' (app: UiApplication.t) =
+ Gc.compact (); (* Best effort to reclaim space *)
+
+ method applicationWillResignActive' (app: UiApplication.t) =
+ ()
+
+ method applicationDidBecomeActive' (app: UiApplication.t) =
+ self#display
+
+ method applicationWillTerminate' (app: UiApplication.t) =
+ ()
+
+ (* Touch events.
+ *)
+ method view'touchesBegan' (view: UiView.t) (touch: Cocoa.point) =
+ begin
+ let touch = self#touch_clamp view touch
+ in let touchdist2 (p, _) = Cocoa.dist2 touch p
+ in let sosites =
+ List.sort (fun a b -> compare (touchdist2 a) (touchdist2 b)) sites
+ in
+ (match sosites with
+ | a :: _ when touchdist2 a < Cocoa.sqr touch_radius ->
+ (* Move an existing site.
+ *)
+ sites <- a :: List.filter ((<>) a) sites
+ | _ ->
+ (* Create a new site.
+ *)
+ sites <- (touch, 1) :: sites
+ );
+ self#display;
+ end
+
+ method view'touchesMoved' (view: UiView.t) (touch: Cocoa.point) =
+ let touch = self#touch_clamp view touch
+ in
+ begin
+ (match sites with
+ | (_, m) :: rest -> sites <- (touch, m) :: rest
+ | _ -> () (* Not possible *)
+ );
+ self#display;
+ end
+
+ method private end_touches (view: UiView.t) (touch: Cocoa.point) =
+ (* If the finished site is very close to another one, merge
+ * them. Otherwise just leave it. Some merged sites have
+ * special behaviors.
+ *)
+ begin
+ (match sites with
+ | (_, am) :: (_ :: _ as rest) ->
+ let tdist2 (p, _) = Cocoa.dist2 touch p
+ in let sorest =
+ List.sort (fun a b -> compare (tdist2 a) (tdist2 b)) rest
+ in
+ (match sorest with
+ | (p,m as s) :: _ when tdist2 s < Cocoa.sqr ident_radius ->
+ let s' = (p, m + am)
+ in
+ sites <-
+ List.map (fun t -> if t = s then s' else t) rest
+ | _ ->
+ sites <- (touch, am) :: rest
+ )
+ | _ -> ()
+ );
+ self#site_behaviors view;
+ end
+
+ method view'touchesEnded' (view: UiView.t) (touch: Cocoa.point) =
+ let touch = self#touch_clamp view touch
+ in
+ begin
+ self#end_touches view touch;
+ self#display;
+ end
+
+ method view'touchesCancelled' (view: UiView.t) (touch: Cocoa.point) =
+ let touch = self#touch_clamp view touch
+ in
+ begin
+ self#end_touches view touch;
+ self#display;
+ end
+
+ method private site_behaviors (view: UiView.t) =
+ (* Go through sites looking for any that have special behaviors.
+ * Right now, sites with multiplicity >= 4 disappear, and sites
+ * with multiplicity 3 cause the number of sites to be doubled
+ * (2N + 4) or halved ((N-4)/2) depending on whether the point
+ * is near the center or the edge.
+ *)
+ let (_, _, wd, ht) = view#frame
+ in let rect = (0.0, 0.0, wd, ht)
+ in let onesite =
+ match sites with
+ | [_] -> true
+ | _ -> false
+ in let pass1 (sites, count, threept) ((pt, m) as site) =
+ if m < 3 then (site :: sites, count + 1, threept)
+ else if m = 3 then ((pt, 1) :: sites, count + 1, Some pt)
+ else if onesite then ((pt, 1) :: sites, count + 1, None)
+ else (sites, count, threept)
+ in
+ match List.fold_left pass1 ([], 0, None) sites with
+ | (sites', _, None) -> sites <- List.rev sites'
+ | (sites', count, Some pt) ->
+ if central rect pt then
+ (* Double the sites.
+ *)
+ let toadd = min max_sites (2 * count + 4) - count
+ in
+ sites <- List.rev (addransites rect pt toadd sites')
+ else
+ (* Halve the sites
+ *)
+ let todel = count - max 1 ((count - 4) / 2)
+ in
+ sites <- List.rev (delransites pt todel sites')
+
+ (* Motion events.
+ *)
+ method viewCanBecomeFirstResponder' (view: UiView.t) =
+ (* Need to be first responder to receive motion events.
+ *)
+ true
+
+ method view'motionBegan' (view: UiView.t) (motion: int) =
+ ()
+
+ method view'motionCancelled' (view: UiView.t) (motion: int) =
+ ()
+
+ method view'motionEnded' (view: UiView.t) (motion: int) =
+ if motion = UiKit.eventSubtypeMotionShake then
+ match theASheet with
+ | None -> ()
+ | Some asheet -> asheet#showInView' view
+
+ (* Draw methods.
+ *)
+ method view'drawRect' (v: UiView.t) (r: Cocoa.rect) =
+ let (_, _, vw, vh) = v#frame
+ in let sitect = List.length sites
+ in let rsites = List.rev sites (* Want to draw newest last *)
+ in let polys = Vorocells.cells_make (vw, vh) (List.map point_of rsites)
+ in
+ begin
+ UiKit.set UiKit.black;
+ UiKit.rectFill (0.0, 0.0, vw, vh);
+ List.iter2 (self#draw_poly 0.5) rsites polys;
+ (match sites with
+ | [s] -> self#draw_figure 0.1 (vw, vh) s
+ | _ -> ()
+ );
+ let wantpoints =
+ (* Don't draw the points for the faux mosaic style when
+ * the number of sites is at the max. It enhances the
+ * mosaic look.
+ *)
+ sitect < max_sites ||
+ not (Colorfield.field_flatstyle colorfield)
+ in
+ if wantpoints then
+ List.iter (self#draw_point 0.75 sitect) rsites;
+ end
+
+ method private draw_poly cont (pt, _) poly =
+ (* Draw the polygonal cell for the given site.
+ *)
+ let polypath poly =
+ match poly with
+ | [] -> () (* Not possible *)
+ | p1 :: rest ->
+ begin
+ bezierpath#moveToPoint' p1;
+ List.iter bezierpath#addLineToPoint' rest;
+ bezierpath#closePath;
+ end
+ in
+ begin
+ bezierpath#removeAllPoints;
+ polypath poly;
+ UiKit.set (Colorfield.field_value colorfield pt);
+ bezierpath#fill;
+ if Colorfield.field_flatstyle colorfield then
+ (* Create a faux mosaic look, just for variety.
+ *)
+ begin
+ bezierpath#setLineWidth' 3.0;
+ UiKit.set UiKit.beige;
+ end
+ else
+ begin
+ bezierpath#setLineWidth' 1.0;
+ UiKit.set (Colorfield.field_contrast colorfield pt cont);
+ end;
+ bezierpath#stroke;
+ end
+
+ method private draw_figure cont (vw, vh) (pt, _) =
+ (* Draw Figure 1 (Psellos logo character) with a contrasting
+ * color for the given site.
+ *)
+ let rect = (10.0, 10.0, vw -. 20.0, vh -. 20.0)
+ in let sfig = Bzpdata.bzp_scale Bzpdata.figure1 rect
+ in
+ begin
+ bezierpath#removeAllPoints;
+ Bzpdata.bzp_iter
+ (fun elem ->
+ match elem with
+ | Bzpdata.BZMove p -> bezierpath#moveToPoint' p
+ | Bzpdata.BZLine p -> bezierpath#addLineToPoint' p
+ | Bzpdata.BZCurve (cp1, cp2, p) ->
+ bezierpath#addCurveToPoint'controlPoint1'controlPoint2'
+ p cp1 cp2
+ | Bzpdata.BZClose -> bezierpath#closePath
+ )
+ sfig;
+ UiKit.set (Colorfield.field_contrast colorfield pt cont);
+ bezierpath#fill;
+ end
+
+ method private draw_point cont sitect (p, m) =
+ let fsct = float_of_int sitect
+ in let baseradius =
+ (* Points get smaller as there are more and more sites.
+ *)
+ if m = 1 then -0.011173 *. fsct +. 5.011173
+ else -0.005587 *. fsct +. 4.005587
+ in
+ begin
+ bezierpath#removeAllPoints;
+ UiKit.set (Colorfield.field_contrast colorfield p cont);
+ Bzpdraw.add_circle bezierpath p baseradius;
+ bezierpath#fill;
+ bezierpath#removeAllPoints;
+ bezierpath#setLineWidth' 2.0;
+ for i = 2 to m do
+ let r = baseradius +. 2.0 +. 3.0 *. float_of_int (i - 2);
+ in
+ Bzpdraw.add_circle bezierpath p r;
+ done;
+ bezierpath#stroke;
+ end
+
+ (* Miscellaneous methods.
+ *)
+ method private back_to_one_dot =
+ (* Preserve the dot closest to the center, it seems friendliest.
+ *)
+ let center =
+ match theDelegator with
+ | None -> (160.0, 230.0)
+ | Some vd ->
+ let (_, _, wd, ht) = vd#frame in (wd /. 2.0, ht /. 2.0)
+ in let centerdist2 (p, _) = Cocoa.dist2 center p
+ in let centercmp a b = compare (centerdist2 a) (centerdist2 b)
+ in
+ match List.sort centercmp sites with
+ | [] -> sites <- []
+ | s :: _ -> sites <- [s]
+
+ method private change_colors =
+ match theDelegator with
+ | None -> ()
+ | Some vd ->
+ let (_, _, wd, ht) = vd#frame
+ in
+ colorfield <- Colorfield.field_make (wd, ht) 7
+
+ method private display =
+ match theDelegator with
+ | None -> ()
+ | Some vd -> vd#setNeedsDisplay
+
+ method private touch_clamp (view: UiView.t) (x, y) =
+ (* The geometric calculations require all touches to be inside
+ * the view.
+ *)
+ let (_, _, wd, ht) = view#frame
+ in
+ (max 0.0 (min x wd), max 0.0 (min y ht))
+end
+
+let () =
+ let wrapped robjcv =
+ let c = new t in let () = c#setContainer robjcv in c
+ in
+ Callback.register "Voronoictlr.wrapped" wrapped
diff --git a/wrap.h b/wrap.h
new file mode 100644
index 0000000..9158c96
--- /dev/null
+++ b/wrap.h
@@ -0,0 +1,22 @@
+/* wrap.h Simple custom wrappers for Voronoi example
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ */
+
+/* An OCaml value wrapped up for access from ObjC.
+ */
+@interface WrapOCaml : NSObject {
+ value contents;
+}
+@property (nonatomic, readonly) value contents;
+@end
+
+/* Wrapped version of Voronoictlr.t
+ */
+@interface Voronoictlr : WrapOCaml
+{
+}
+@property (nonatomic, retain) IBOutlet UIView *delegator;
+@end
diff --git a/wrap.m b/wrap.m
new file mode 100644
index 0000000..f6a6086
--- /dev/null
+++ b/wrap.m
@@ -0,0 +1,919 @@
+/* wrap.m Simple custom wrappers for Voronoi example
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ */
+# import
+# import
+# import
+# import
+# import
+# import
+# import
+# import "ViewDelegator.h"
+# import "wrap.h"
+
+/* Represent raw ObjC object pointers in OCaml as nativeint values.
+ *
+ * Note: to keep things simple, we retain ObjC values and don't release
+ * them. It works for this example because the few ObjC objects
+ * accessible from the OCaml side are never destroyed.
+ *
+ * In a more dynamic setting, need to gain control when the OCaml
+ * wrapper objects are GCed and release the wrapped up ObjC objects.
+ */
+static value wrapRawObjC(id obj) {
+ CAMLparam0();
+ [obj retain];
+ CAMLreturn(caml_copy_nativeint((intnat) obj));
+}
+
+static id unwrapRawObjC(value objcval) {
+ return (id) Nativeint_val(objcval);
+}
+
+/* Need to be able to determine the OCaml object that wraps a given ObjC
+ * object. In the simple setup here, the association is permanent and
+ * there are very few objects involved. So we can use a little table.
+ * (Getting the ObjC object that wraps an OCaml object is easier; we
+ * just use the container method of Wrappee.t.)
+ */
+static struct {
+ id objc_obj;
+ value ocaml_obj;
+} g_ocaml_wrapper[16];
+static int g_ocwrap_ct = 0;
+
+
+static value find_ocaml_wrapper(id obj) {
+ int i;
+
+ for(i = 0; i < g_ocwrap_ct; i++)
+ if(g_ocaml_wrapper[i].objc_obj == obj)
+ return g_ocaml_wrapper[i].ocaml_obj;
+ return 0;
+}
+
+
+static value wrapObjC(char *wrapcs, id obj) {
+ /* Create a new OCaml object that wraps the given ObjC object.
+ * wrapcs gives the name of the closure for creating an OCaml
+ * wrapper of the correct type. A closure is registered by each
+ * OCaml class that wraps an ObjC class (i.e., each subclass of
+ * Wrapper.t).
+ */
+ CAMLparam0();
+ CAMLlocal1(val);
+ value *closure;
+
+ closure = (value *) caml_named_value(wrapcs);
+ if(closure == NULL) {
+ /* Can't create an instance of an unregistered class. If this
+ * happens, things will go very bad from here.
+ */
+ printf("wrapObjC lookup failure for %s\n", wrapcs);
+ fflush(stdout);
+ CAMLreturn(Val_unit); /* Not type safe, should never happen */
+ }
+ val = caml_callback(*closure, wrapRawObjC(obj));
+
+ /* Enter the wrapping into the table.
+ */
+ if(g_ocwrap_ct >= sizeof g_ocaml_wrapper / sizeof g_ocaml_wrapper[0]) {
+ /* Things might go bad from here if we need to access the
+ * wrapper later from the ObjC side. For this simple example it
+ * never happens because there are only 2 or 3 wrapped ObjC
+ * objects.
+ */
+ printf("wrapObjC table overflow for %s\n", wrapcs);
+ fflush(stdout);
+ } else {
+ g_ocaml_wrapper[g_ocwrap_ct].objc_obj = obj;
+ g_ocaml_wrapper[g_ocwrap_ct].ocaml_obj = val;
+ caml_register_global_root(&g_ocaml_wrapper[g_ocwrap_ct].ocaml_obj);
+ g_ocwrap_ct++;
+ }
+
+ CAMLreturn(val);
+}
+
+static id unwrapObjC(value obj) {
+ /* Return the ObjC object wrapped by the given OCaml object.
+ */
+ CAMLparam1(obj);
+ CAMLlocal1(objcval);
+
+ objcval =
+ caml_callback(
+ caml_get_public_method(obj, caml_hash_variant("contents")),
+ obj);
+ CAMLreturnT(id, unwrapRawObjC(objcval));
+}
+
+
+/* Subclasses of WrapOCaml wrap OCaml objects as ObjC objects.
+ */
+@implementation WrapOCaml {
+}
+
+@dynamic contents;
+
+- (value) contents
+{
+ return contents;
+}
+
+
+- (void) setContents: (value) aValue
+{
+ contents = aValue;
+}
+
+
+- (WrapOCaml *) init
+{
+ /* Create a new OCaml object that is wrapped by self. We match the
+ * OCaml class to our own class by name--simple but effective. We
+ * then call the closure for creating a wrapped object, which is
+ * registered by each OCaml class that can be wrapped by an ObjC
+ * class (i.e., each subtype of Wrappee.t).
+ */
+# define CLOSURE_SFX ".wrapped"
+# define CLOSURE_SFX_LEN (sizeof CLOSURE_SFX - 1)
+ const char *classname;
+ char closurename[128];
+ value *closure;
+
+ if((self = [super init]) != nil) {
+ classname = object_getClassName(self);
+ if(strlen(classname) + CLOSURE_SFX_LEN >= sizeof closurename) {
+ printf("[WrapOCaml init]: class name too long: %s\n", classname);
+ fflush(stdout);
+ return nil;
+ }
+ strcpy(closurename, classname);
+ strcat(closurename, CLOSURE_SFX);
+ closure = (value *) caml_named_value(closurename);
+ if(closure == NULL) {
+ printf("[WrapOCaml init]: lookup failure for %s\n", closurename);
+ fflush(stdout);
+ return nil;
+ }
+ contents = caml_callback(*closure, wrapRawObjC(self));
+ caml_register_global_root(&contents);
+ }
+ return self;
+}
+
+- (void) dealloc
+{
+ if(contents != 0) {
+ caml_remove_global_root(&contents);
+ contents = 0;
+ }
+ [super dealloc];
+}
+
+@end
+
+/* Conversion utilities.
+ */
+static void Point_val(CGPoint *ptp, value pointval)
+{
+ CAMLparam1(pointval);
+
+ ptp->x = Double_val(Field(pointval, 0));
+ ptp->y = Double_val(Field(pointval, 1));
+
+ CAMLreturn0;
+}
+
+static value Val_rect(CGRect *rectp)
+{
+ CAMLparam0();
+ CAMLlocal1(rectval);
+
+ rectval = caml_alloc(4, 0);
+ Store_field(rectval, 0, caml_copy_double(rectp->origin.x));
+ Store_field(rectval, 1, caml_copy_double(rectp->origin.y));
+ Store_field(rectval, 2, caml_copy_double(rectp->size.width));
+ Store_field(rectval, 3, caml_copy_double(rectp->size.height));
+
+ CAMLreturn(rectval);
+}
+
+static void Rect_val(CGRect *rectp, value rectval)
+{
+ CAMLparam1(rectval);
+
+ rectp->origin.x = Double_val(Field(rectval, 0));
+ rectp->origin.y = Double_val(Field(rectval, 1));
+ rectp->size.width = Double_val(Field(rectval, 2));
+ rectp->size.height = Double_val(Field(rectval, 3));
+
+ CAMLreturn0;
+}
+
+
+static SEL SEL_val(value selectval)
+{
+ /* Translate the OCaml string into an ObjC selector.
+ *
+ * Conventionally we use '\'' in OCaml where ':' appears in ObjC.
+ * So here we translate back.
+ */
+ char *prime;
+ SEL res;
+
+ char *ocamlsel = String_val(selectval);
+ char *buf = malloc(strlen(ocamlsel) + 1);
+ strcpy(buf, ocamlsel);
+ prime = buf;
+ while((prime = strchr(prime, '\'')) != NULL)
+ *prime = ':';
+ res = sel_registerName(buf);
+ free(buf);
+ return res;
+}
+
+static NSString *StringO_val(value so)
+{
+ CAMLparam1(so);
+ NSString *res;
+
+ if(Is_long(so))
+ res = nil;
+ else
+ res = [NSString stringWithUTF8String: String_val(Field(so, 0))];
+ CAMLreturnT(NSString *, res);
+}
+
+
+/* OCaml objects accessed from ObjC.
+ */
+
+@implementation Voronoictlr : WrapOCaml
+{
+}
+
+@dynamic delegator;
+
+- (UIView *) delegator
+{
+ CAMLparam0();
+ CAMLlocal2(selfval, delegatorval);
+
+ selfval = [self contents];
+ delegatorval =
+ caml_callback(
+ caml_get_public_method(selfval, caml_hash_variant("delegator")),
+ selfval);
+ CAMLreturnT(UIView *, unwrapObjC(delegatorval));
+}
+
+- (void) setDelegator: (UIView *) aView
+{
+ CAMLparam0();
+ CAMLlocal2(selfval, delegatorval);
+
+ selfval = [self contents];
+ delegatorval = wrapObjC("UIView.wrap", (id) aView);
+ (void)
+ caml_callback2(
+ caml_get_public_method(selfval, caml_hash_variant("setDelegator'")),
+ selfval,
+ delegatorval);
+ CAMLreturn0;
+}
+
+- (void) applicationDidFinishLaunching: (UIApplication *) anApplication
+{
+ CAMLparam0();
+ CAMLlocal2(selfval, applval);
+
+ selfval = [self contents];
+ if((applval = find_ocaml_wrapper(anApplication)) == 0)
+ applval = wrapObjC("UIApplication.wrap", (id) anApplication);
+ (void)
+ caml_callback2(
+ caml_get_public_method(
+ selfval,
+ caml_hash_variant("applicationDidFinishLaunching'")),
+ selfval,
+ applval);
+ CAMLreturn0;
+}
+
+- (void) applicationWillResignActive: (UIApplication *) anApplication
+{
+ CAMLparam0();
+ CAMLlocal2(selfval, applval);
+
+ selfval = [self contents];
+ if((applval = find_ocaml_wrapper(anApplication)) == 0)
+ applval = wrapObjC("UIApplication.wrap", (id) anApplication);
+ (void)
+ caml_callback2(
+ caml_get_public_method(
+ selfval,
+ caml_hash_variant("applicationWillResignActive'")),
+ selfval,
+ applval);
+ CAMLreturn0;
+}
+
+- (void) applicationDidBecomeActive: (UIApplication *) anApplication
+{
+ CAMLparam0();
+ CAMLlocal2(selfval, applval);
+
+ selfval = [self contents];
+ if((applval = find_ocaml_wrapper(anApplication)) == 0)
+ applval = wrapObjC("UIApplication.wrap", (id) anApplication);
+ (void)
+ caml_callback2(
+ caml_get_public_method(
+ selfval,
+ caml_hash_variant("applicationDidBecomeActive'")),
+ selfval,
+ applval);
+ CAMLreturn0;
+}
+
+
+- (BOOL) viewCanBecomeFirstResponder: (UIView *) aView
+{
+ CAMLparam0();
+ CAMLlocal3(selfval, viewval, resval);
+
+ selfval = [self contents];
+
+ if((viewval = find_ocaml_wrapper(aView)) == 0)
+ viewval = wrapObjC("UIView.wrap", (id) aView);
+
+ resval =
+ caml_callback2(
+ caml_get_public_method(selfval,
+ caml_hash_variant("viewCanBecomeFirstResponder'")),
+ selfval,
+ viewval);
+ CAMLreturnT(BOOL, Bool_val(resval));
+}
+
+
+static void touch_event(value selfval, UIView *aView, NSSet *touches,
+ UIEvent *event, char *ocmeth)
+{
+ /* For this simple test, we assume there's just one touch, and we
+ * represent it by a point.
+ */
+ CAMLparam1(selfval);
+ CAMLlocal2(viewval, pointval);
+ UITouch *touch;
+ CGPoint location;
+
+ if((viewval = find_ocaml_wrapper(aView)) == 0)
+ viewval = wrapObjC("UIView.wrap", (id) aView);
+
+ if((touch = (UITouch *) [touches anyObject]) == nil)
+ CAMLreturn0; /* Not really possible */
+
+ location = [touch locationInView: aView];
+
+ pointval = caml_alloc(2, 0);
+ Store_field(pointval, 0, caml_copy_double(location.x));
+ Store_field(pointval, 1, caml_copy_double(location.y));
+
+ (void)
+ caml_callback3(
+ caml_get_public_method(
+ selfval,
+ caml_hash_variant(ocmeth)),
+ selfval,
+ viewval,
+ pointval);
+ CAMLreturn0;
+}
+
+
+- (void) view: (UIView *) aView
+ touchesBegan: (NSSet *) touches
+ withEvent: (UIEvent *) event
+{
+ touch_event([self contents], aView, touches, event,
+ "view'touchesBegan'");
+}
+
+
+- (void) view: (UIView *) aView
+ touchesMoved: (NSSet *) touches
+ withEvent: (UIEvent *) event
+{
+ touch_event([self contents], aView, touches, event,
+ "view'touchesMoved'");
+}
+
+
+- (void) view: (UIView *) aView
+ touchesEnded: (NSSet *) touches
+ withEvent: (UIEvent *) event
+{
+ touch_event([self contents], aView, touches, event,
+ "view'touchesEnded'");
+}
+
+
+- (void) view: (UIView *) aView
+ touchesCancelled: (NSSet *) touches
+ withEvent: (UIEvent *) event
+{
+ touch_event([self contents], aView, touches, event,
+ "view'touchesCancelled'");
+}
+
+
+static void motion_event(value selfval, UIView *aView, UIEventSubtype motion,
+ UIEvent *event, char *ocmeth)
+{
+ CAMLparam1(selfval);
+ CAMLlocal1(viewval);
+
+ if((viewval = find_ocaml_wrapper(aView)) == 0)
+ viewval = wrapObjC("UIView.wrap", (id) aView);
+
+ (void)
+ caml_callback3(
+ caml_get_public_method(selfval, caml_hash_variant(ocmeth)),
+ selfval,
+ viewval,
+ Val_int(motion));
+ CAMLreturn0;
+}
+
+
+- (void) view: (UIView *) aView
+ motionBegan: (UIEventSubtype) motion
+ withEvent: (UIEvent *) event
+{
+ motion_event([self contents], aView, motion, event,
+ "view'motionBegan'");
+}
+
+
+- (void) view: (UIView *) aView
+ motionCancelled: (UIEventSubtype) motion
+ withEvent: (UIEvent *) event
+{
+ motion_event([self contents], aView, motion, event,
+ "view'motionCancelled'");
+}
+
+
+- (void) view: (UIView *) aView
+ motionEnded: (UIEventSubtype) motion
+ withEvent: (UIEvent *) event
+{
+ motion_event([self contents], aView, motion, event,
+ "view'motionEnded'");
+}
+
+
+- (void) view: (UIView *) aView drawRect: (CGRect) rect
+{
+ CAMLparam0();
+ CAMLlocal2(selfval, viewval);
+
+ selfval = [self contents];
+
+ if((viewval = find_ocaml_wrapper(aView)) == 0)
+ viewval = wrapObjC("UIView.wrap", (id) aView);
+
+ (void)
+ caml_callback3(
+ caml_get_public_method(selfval,
+ caml_hash_variant("view'drawRect'")),
+ selfval,
+ viewval,
+ Val_rect(&rect));
+ CAMLreturn0;
+}
+
+@end
+
+
+/* ObjC objects accessed from OCaml.
+ */
+
+/* UIKit
+ */
+
+value UIKit_RectFill(value rectval)
+/* Cocoa.rect -> unit */
+{
+ CAMLparam1(rectval);
+ CGRect rect;
+
+ Rect_val(&rect, rectval);
+ UIRectFill(rect);
+
+ CAMLreturn(Val_unit);
+}
+
+
+value UIKit_set(value colorval)
+/* UiKit.color -> unit */
+{
+ CAMLparam1(colorval);
+
+ UIColor *color =
+ [UIColor colorWithHue: Double_val(Field(colorval, 0))
+ saturation: Double_val(Field(colorval, 1))
+ brightness: Double_val(Field(colorval, 2))
+ alpha: Double_val(Field(colorval, 3))];
+ [color set];
+
+ CAMLreturn(Val_unit);
+}
+
+
+value UIKit_setFill(value colorval)
+/* UiKit.color -> unit */
+{
+ CAMLparam1(colorval);
+
+ UIColor *color =
+ [UIColor colorWithHue: Double_val(Field(colorval, 0))
+ saturation: Double_val(Field(colorval, 1))
+ brightness: Double_val(Field(colorval, 2))
+ alpha: Double_val(Field(colorval, 3))];
+ [color setFill];
+
+ CAMLreturn(Val_unit);
+}
+
+
+value UIKit_setStroke(value colorval)
+/* UiKit.color -> unit */
+{
+ CAMLparam1(colorval);
+
+ UIColor *color =
+ [UIColor colorWithHue: Double_val(Field(colorval, 0))
+ saturation: Double_val(Field(colorval, 1))
+ brightness: Double_val(Field(colorval, 2))
+ alpha: Double_val(Field(colorval, 3))];
+ [color setStroke];
+
+ CAMLreturn(Val_unit);
+}
+
+
+value UIKit_string_sizeWithFont_(value stringval, value objcval)
+/* string -> nativeint -> Cocoa.size */
+{
+ CAMLparam2(stringval, objcval);
+ CAMLlocal1(sizeval);
+ NSString *string;
+ UIFont *font;
+ CGSize size;
+
+ string = [NSString stringWithUTF8String: String_val(stringval)];
+ font = unwrapRawObjC(objcval);
+
+ size = [string sizeWithFont: font];
+
+ sizeval = caml_alloc(2, 0);
+ Store_field(sizeval, 0, caml_copy_double(size.width));
+ Store_field(sizeval, 1, caml_copy_double(size.height));
+
+ CAMLreturn(sizeval);
+}
+
+value UIKit_string_drawAtPoint_withFont_(value stringval, value pointval,
+ value objcval)
+/* string -> Cocoa.point -> nativeint -> unit */
+{
+ CAMLparam3(stringval, pointval, objcval);
+ NSString *string;
+ CGPoint pt;
+ UIFont *font;
+
+ string = [NSString stringWithUTF8String: String_val(stringval)];
+ Point_val(&pt, pointval);
+ font = unwrapRawObjC(objcval);
+
+ [string drawAtPoint: pt withFont: font];
+
+ CAMLreturn(Val_unit);
+}
+
+/* UIFont
+ */
+
+value UIFont_fontWithName_size_(value nameval, value sizeval)
+/* string -> float -> UiFont.t */
+{
+ CAMLparam2(nameval, sizeval);
+ NSString *name;
+ CGFloat size;
+ UIFont *font;
+
+ name = [NSString stringWithUTF8String: String_val(nameval)];
+ size = Double_val(sizeval);
+ font = [UIFont fontWithName: name size: size];
+
+ CAMLreturn(wrapObjC("UIFont.wrap", (id) font));
+}
+
+/* UIBezierPath
+ */
+value UIBezierPath_bezierPath(value unitval)
+/* unit -> UiBezierPath.t */
+{
+ CAMLparam1(unitval);
+ UIBezierPath *bzp;
+
+ bzp = [UIBezierPath bezierPath];
+ CAMLreturn(wrapObjC("UIBezierPath.wrap", (id) bzp));
+}
+
+value UIBezierPath_bezierPathWithOvalInRect_(value rectval)
+/* Cocoa.rect -> UiBezierPath.t */
+{
+ CAMLparam1(rectval);
+ CGRect rect;
+ UIBezierPath *bzp;
+
+ Rect_val(&rect, rectval);
+ bzp = [UIBezierPath bezierPathWithOvalInRect: rect];
+
+ CAMLreturn(wrapObjC("UIBezierPath.wrap", (id) bzp));
+}
+
+value UIBezierPath_moveToPoint_(value objcval, value pointval)
+/* nativeint -> Cocoa.point -> unit */
+{
+ CAMLparam2(objcval, pointval);
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+ CGPoint pt;
+
+ Point_val(&pt, pointval);
+ [bzp moveToPoint: pt];
+
+ CAMLreturn(Val_unit);
+}
+
+value UIBezierPath_addLineToPoint_(value objcval, value pointval)
+/* nativeint -> Cocoa.point -> unit */
+{
+ CAMLparam2(objcval, pointval);
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+ CGPoint pt;
+
+ Point_val(&pt, pointval);
+ [bzp addLineToPoint: pt];
+
+ CAMLreturn(Val_unit);
+}
+
+value UIBezierPath_addCurveToPoint_controlPoint1_controlPoint2_(value objcval,
+ value pointval, value cp1val, value cp2val)
+/* nativeint -> Cocoa.point -> Cocoa.point -> Cocoa.point -> unit */
+{
+ CAMLparam4(objcval, pointval, cp1val, cp2val);
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+ CGPoint pt, cp1, cp2;
+
+ Point_val(&pt, pointval);
+ Point_val(&cp1, cp1val);
+ Point_val(&cp2, cp2val);
+ [bzp addCurveToPoint: pt
+ controlPoint1: cp1
+ controlPoint2: cp2];
+
+ CAMLreturn(Val_unit);
+}
+
+value UIBezierPath_closePath(value objcval)
+/* nativeint -> unit */
+{
+ CAMLparam1(objcval);
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+
+ [bzp closePath];
+
+ CAMLreturn(Val_unit);
+}
+
+value UIBezierPath_removeAllPoints(value objcval)
+/* nativeint -> unit */
+{
+ CAMLparam1(objcval);
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+
+ [bzp removeAllPoints];
+
+ CAMLreturn(Val_unit);
+}
+
+value UIBezierPath_lineWidth(value objcval)
+/* nativeint -> float */
+{
+ CAMLparam1(objcval);
+
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+
+ CAMLreturn(caml_copy_double([bzp lineWidth]));
+}
+
+value UIBezierPath_setLineWidth_(value objcval, value widval)
+/* nativeint -> float -> unit */
+{
+ CAMLparam2(objcval, widval);
+
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+ [bzp setLineWidth: Double_val(widval)];
+
+ CAMLreturn(Val_unit);
+}
+
+value UIBezierPath_fill(value objcval)
+/* nativeint -> unit */
+{
+ CAMLparam1(objcval);
+
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+ [bzp fill];
+ CAMLreturn(Val_unit);
+}
+
+value UIBezierPath_stroke(value objcval)
+/* nativeint -> unit */
+{
+ CAMLparam1(objcval);
+
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+ [bzp stroke];
+ CAMLreturn(Val_unit);
+}
+
+value UIBezierPath_containsPoint_(value objcval, value pointval)
+/* nativeint -> Cocoa.point -> bool */
+{
+ CAMLparam2(objcval, pointval);
+ CGPoint pt;
+
+ UIBezierPath *bzp = unwrapRawObjC(objcval);
+ Point_val(&pt, pointval);
+
+ CAMLreturn(Val_bool([bzp containsPoint: pt]));
+}
+
+/* UIView
+ */
+
+value UIView_isFirstResponder(value objcval)
+/* nativeint -> bool */
+{
+ CAMLparam1(objcval);
+
+ UIView *view = unwrapRawObjC(objcval);
+ CAMLreturn(Val_bool([view isFirstResponder]));
+}
+
+value UIView_becomeFirstResponder(value objcval)
+/* nativeint -> bool */
+{
+ CAMLparam1(objcval);
+
+ UIView *view = unwrapRawObjC(objcval);
+ CAMLreturn(Val_bool([view becomeFirstResponder]));
+}
+
+value UIView_frame(value objcval)
+/* nativeint -> Cocoa.rect */
+{
+ CAMLparam1(objcval);
+ CGRect rect;
+
+ UIView *view = unwrapRawObjC(objcval);
+ rect = [view frame];
+ CAMLreturn(Val_rect(&rect));
+}
+
+value UIView_setNeedsDisplay(value objcval)
+/* nativeint -> unit */
+{
+ CAMLparam1(objcval);
+
+ UIView *view = unwrapRawObjC(objcval);
+ [view setNeedsDisplay];
+ CAMLreturn(Val_unit);
+}
+
+/* UIActionSheet
+ */
+
+/* A little class to wrap the delegate.
+ */
+@interface ASDelegate : NSObject {
+ value contents;
+}
+- (void) setContents: (value) aValue;
+@end
+
+@implementation ASDelegate {
+}
+
+- (void) setContents: (value) aValue
+{
+ contents = aValue;
+ caml_register_global_root(&contents);
+}
+
+- (void) actionSheet: (UIActionSheet *) a clickedButtonAtIndex: (NSInteger) ix
+{
+ CAMLparam0();
+ CAMLlocal1(asval);
+
+ if((asval = find_ocaml_wrapper(a)) == 0)
+ asval = wrapObjC("UIActionSheet.wrap", (id) a);
+
+ (void)
+ caml_callback3(
+ caml_get_public_method(contents,
+ caml_hash_variant("actionSheet'clickedButtonAtIndex'")),
+ contents,
+ asval,
+ Val_int(ix));
+ CAMLreturn0;
+}
+@end
+
+value UIActionSheet_initWithTDCDO(value objcval, value titleoval,
+ value delegval, value canceloval, value destruoval,
+ value othersval)
+/* nativeint -> string option -> UiActionSheet.delegate -> string option ->
+ * string option -> string list -> UiActionSheet.t
+ */
+{
+# define MAXOTITLES 7
+ CAMLparam5(objcval, titleoval, delegval, canceloval, destruoval);
+ CAMLxparam1(othersval);
+ UIActionSheet *as, *asi;
+ NSString *title, *cancel, *destructive, *others[MAXOTITLES + 1];
+ ASDelegate *deleg;
+ int i;
+
+ as = unwrapRawObjC(objcval);
+ if(as == nil)
+ as = [UIActionSheet alloc];
+ title = StringO_val(titleoval);
+ deleg = [[ASDelegate alloc] init];
+ [deleg setContents: delegval];
+ cancel = StringO_val(canceloval);
+ destructive = StringO_val(destruoval);
+ for(i = 0; i < MAXOTITLES; i++) {
+ if(Is_long(othersval))
+ break;
+ others[i] =
+ [NSString stringWithUTF8String: String_val(Field(othersval, 0))];
+ othersval = Field(othersval, 1);
+ }
+ others[i] = nil;
+
+ asi = [as initWithTitle: title
+ delegate: deleg
+ cancelButtonTitle: cancel
+ destructiveButtonTitle: destructive
+ otherButtonTitles:
+ others[0], others[1], others[2], others[3],
+ others[4], others[5], others[6], others[7], nil];
+ [asi autorelease]; /* wrapObjC will retain */
+
+ CAMLreturn(wrapObjC("UIActionSheet.wrap", (id) asi));
+}
+
+
+value UIActionSheet_initWithTDCDO_bytecode(value *argv, int argn)
+{
+ return UIActionSheet_initWithTDCDO(argv[0], argv[1], argv[2], argv[3],
+ argv[4], argv[5]);
+}
+
+value UIActionSheet_showInView_(value objcval, value viewval)
+/* nativeint -> nativeint -> unit */
+{
+ CAMLparam2(objcval, viewval);
+
+ UIActionSheet *as;
+ UIView *view;
+
+ as = unwrapRawObjC(objcval);
+ view = unwrapRawObjC(viewval);
+
+ [as showInView: view];
+
+ CAMLreturn(Val_unit);
+}
diff --git a/wrappee.ml b/wrappee.ml
new file mode 100644
index 0000000..15f1e76
--- /dev/null
+++ b/wrappee.ml
@@ -0,0 +1,17 @@
+(* wrappee.ml OCaml objects that are wrapped inside ObjC objects
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+class t =
+ (* Subclasses of this class are wrapped inside ObjC objects.
+ *)
+ object
+ val mutable container: nativeint = 0n (* 0n -> no wrapper *)
+ method container = container
+ method setContainer robjcv = container <- robjcv
+ end
+
+let nil = new t (* Unwraps as nil in ObjC *)
diff --git a/wrappee.mli b/wrappee.mli
new file mode 100644
index 0000000..b88a385
--- /dev/null
+++ b/wrappee.mli
@@ -0,0 +1,13 @@
+(* wrappee.mli OCaml objects that are wrapped inside ObjC objects
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+class t :
+object
+ method container : nativeint
+ method setContainer : nativeint -> unit
+end
+
+val nil : t
diff --git a/wrapper.ml b/wrapper.ml
new file mode 100644
index 0000000..493d473
--- /dev/null
+++ b/wrapper.ml
@@ -0,0 +1,13 @@
+(* wrapper.ml OCaml objects that wrap ObjC objects inside
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+
+class t (rawobjcval: nativeint) =
+(* Subclasses of this class wrap ObjC objects as OCaml objects.
+ *)
+object
+ method contents = rawobjcval
+end
diff --git a/wrapper.mli b/wrapper.mli
new file mode 100644
index 0000000..b83a77b
--- /dev/null
+++ b/wrapper.mli
@@ -0,0 +1,10 @@
+(* wrapper.mli OCaml objects that wrap ObjC objects inside
+ *
+ * Copyright (c) 2011 Psellos http://psellos.com
+ * Licensed under the MIT license:
+ * http://www.opensource.org/licenses/mit-license.php
+ *)
+class t : nativeint ->
+object
+ method contents : nativeint
+end