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 + + com.apple.InterfaceBuilder.IBCocoaTouchPlugin + 301 + + + YES + IBUIWindow + IBUICustomObject + IBUIView + IBProxyObject + + + YES + com.apple.InterfaceBuilder.IBCocoaTouchPlugin + + + YES + + YES + + + + + 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