view modules/freetype.tp @ 328:c1fad3d93861

Add getKerning to freetype module and use it in sample
author Michael Pavone <pavone@retrodev.com>
date Wed, 25 Mar 2015 00:16:37 -0700
parents 50760ba52b11
children
line wrap: on
line source

{
	_helper <- #{
		includeSystemHeader: "ft2build.h"
		includeSystemHeader: FT_FREETYPE_H
		llMessage: newFace withVars: {
			libOpaque <- cpointer ptr
			opath <- object ptr
			oindex <- object ptr
			path <- string ptr
			index <- obj_int32 ptr
			faceOpaque <- cpointer ptr
			rescode <- int32_t
		} andCode: :libOpaque opath oindex {
			path <- (mcall: string 1 opath) castTo: (string ptr)
			index <- (mcall: int32 1 oindex) castTo: (obj_int32 ptr)
			faceOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
			rescode <- FT_New_Face: (libOpaque val) (path data) (index num) ((addr_of: (faceOpaque val)) castTo: (FT_Face ptr))
			if: rescode = 0 {
				mcall: value 2 option faceOpaque
			} else: {
				mcall: none 1 option
			}
		}
		
		llMessage: getFirstChar withVars: {
			opaque <- cpointer ptr
			glyphIndex <- obj_uint32 ptr
			charCode <- obj_uint32 ptr
			makeChar <- lambda ptr
		} andCode: :opaque makeChar {
			glyphIndex <- make_object: (addr_of: obj_uint32_meta) NULL 0
			charCode <- make_object: (addr_of: obj_uint32_meta) NULL 0
			charCode num!: (FT_Get_First_Char: (opaque val) (addr_of: (glyphIndex num)))
			ccall: makeChar 2 charCode glyphIndex
		}
		
		llMessage: getNextChar withVars: {
			opaque <- cpointer ptr
			ocurChar <- object ptr
			curChar <- obj_uint32 ptr
			glyphIndex <- obj_uint32 ptr
			charCode <- obj_uint32 ptr
			makeChar <- lambda ptr
		} andCode: :opaque ocurChar makeChar {
			curChar <- (mcall: uint32 1 ocurChar) castTo: (obj_uint32 ptr)
			glyphIndex <- make_object: (addr_of: obj_uint32_meta) NULL 0
			charCode <- make_object: (addr_of: obj_uint32_meta) NULL 0
			charCode num!: (FT_Get_Next_Char: (opaque val) (curChar num) (addr_of: (glyphIndex num)))
			ccall: makeChar 2 charCode glyphIndex
		}
	}
	
	_makeSlot <- :opaque {
		#{
			llProperty: slot withType: FT_GlyphSlot
			llMessage: _ptr_init withVars: {
				opaque <- cpointer ptr
			} andCode: :opaque {
				slot <- opaque val
				self
			}
			
			llMessage: linearHoriAdvance withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (slot linearHoriAdvance)
				intret
			}
			
			llMessage: linearVertAdvance withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (slot linearVertAdvance)
				intret
			}
			
			llMessage: bitmapTop withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (slot bitmap_top)
				intret
			}
			
			llMessage: bitmapLeft withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (slot bitmap_left)
				intret
			}
			
			llMessage: bitmapRows withVars: {
				uintret <- obj_uint32 ptr
			} andCode: {
				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
				uintret num!: ((addr_of: (slot bitmap)) rows)
				uintret
			}
			
			llMessage: bitmapWidth withVars: {
				uintret <- obj_uint32 ptr
			} andCode: {
				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
				uintret num!: ((addr_of: (slot bitmap)) width)
				uintret
			}
			
			llMessage: bitmapPitch withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_uint32_meta) NULL 0
				intret num!: ((addr_of: (slot bitmap)) pitch)
				intret
			}
			
			llMessage: bitmapData withVars: {
				opaque <- cpointer ptr
				size <- obj_int32 ptr
			} andCode: {
				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
				opaque val!: ((addr_of: (slot bitmap)) buffer)
				size <- make_object: (addr_of: obj_int32_meta) NULL 0
				size num!: ((addr_of: (slot bitmap)) rows) * ((addr_of: (slot bitmap)) pitch)
				mcall: fromOpaque:withSize 3 bytearray opaque size
			}
			
			llMessage: renderGlyph withVars: {
				omode <- object ptr
				mode <- obj_uint32 ptr
				intret <- obj_int32 ptr
			} andCode: :omode {
				mode <- (mcall: uint32 1 omode) castTo: (obj_uint32 ptr)
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (FT_Render_Glyph: slot (mode num))
				intret
			}
		} _ptr_init: opaque
	}
	
	_makeChar <- :_charcode _glyph {
		#{
			charcode <- _charcode
			glyph <- _glyph
		}
	}
	_makeFace <- :opaque {
		#{
			llProperty: face withType: FT_Face
			llProperty: makeSlot withType: (lambda ptr)
			llMessage: _ptr_init withVars: {
				opaque <- cpointer ptr
				makeSlotLambda <- lambda ptr
			} andCode: :opaque makeSlotLambda {
				face <- opaque val
				makeSlot <- makeSlotLambda
				self
			}
			
			llMessage: faceOpaque withVars: {
				opaque <- cpointer ptr
			} andCode: {
				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
				opaque val!: face
				opaque
			}
			
			llMessage: setCharWidth:height:hRes:vRes withVars: {
				ohsize <- object ptr
				hsize <- obj_float32 ptr
				ovsize <- object ptr
				vsize <- obj_float32 ptr
				ohres <- object ptr
				hres <- obj_int32 ptr
				ovres <- object ptr
				vres <- obj_int32 ptr
				intret <- obj_int32 ptr
			} andCode: :ohsize ovsize :ohres :ovres {
				hsize <- (mcall: f32 1 ohsize) castTo: (obj_float32 ptr)
				vsize <- (mcall: f32 1 ovsize) castTo: (obj_float32 ptr)
				hres <- (mcall: int32 1 ohres) castTo: (obj_int32 ptr)
				vres <- (mcall: int32 1 ovres) castTo: (obj_int32 ptr)
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (FT_Set_Char_Size: face (hsize num) * 64 (vsize num) * 64 (hres num) (vres num))
				intret
			}
			
			setCharSize:res <- :size :res {
				setCharWidth: size height: size hRes: res vRes: res
			}
			
			llMessage: getCharIndex withVars: {
				ocharcode <- object ptr
				charcode <- obj_uint32 ptr
				uintret <- obj_uint32 ptr
			} andCode: :ocharcode {
				charcode <- (mcall: uint32 1 ocharcode) castTo: (obj_uint32 ptr)
				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
				uintret num!: (FT_Get_Char_Index: face (charcode num))
				uintret
			}
			
			llMessage: loadGlyph:flags withVars: {
				oindex <- object ptr
				index <- obj_uint32 ptr
				oflags <- object ptr
				flags <- obj_uint32 ptr
				intret <- obj_int32 ptr
			} andCode: :oindex :oflags {
				index <- (mcall: uint32 1 oindex) castTo: (obj_uint32 ptr)
				flags <- (mcall: uint32 1 oflags) castTo: (obj_uint32 ptr)
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (FT_Load_Glyph: face (index num) (flags num))
				intret
			}
			
			llMessage: glyphSlot withVars: {
				opaque <- cpointer ptr
			} andCode: {
				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
				opaque val!: (face glyph)
				ccall: makeSlot 1 opaque
			}
			
			llMessage: unitsPerEm withVars: {
				u16ret <- obj_uint16 ptr
			} andCode: {
				u16ret <- make_object: (addr_of: obj_uint16_meta) NULL 0
				u16ret num!: (face units_per_EM)
				u16ret
			}
			
			llMessage: hasKerning? withVars: {
				ret <- object ptr
			} andCode: {
				if: (FT_HAS_KERNING: face) {
					true
				} else {
					false
				}
			}
			
			llMessage: getKerning:mode withVars: {
				oleft <- object ptr
				oright <- object ptr
				omode <- object ptr
				left <- obj_uint32 ptr
				right <- obj_uint32 ptr
				mode <- obj_uint32 ptr
				x <- obj_int32 ptr
				y <- obj_int32 ptr
				ret <- object ptr
				kernVec <- FT_Vector
				err <- int
			} andCode: :oleft oright :omode {
				left <- (mcall: uint32 1 oleft) castTo: (obj_uint32 ptr)
				right <- (mcall: uint32 1 oright) castTo: (obj_uint32 ptr)
				mode <- (mcall: uint32 1 omode) castTo: (obj_uint32 ptr)
				err <- FT_Get_Kerning: face (left num) (right num) (mode num) (addr_of: kernVec)
				if: err != 0 {
					mcall: none 1 option
				} else: {
					x <- make_object: (addr_of: obj_int32_meta) NULL 0
					y <- make_object: (addr_of: obj_int32_meta) NULL 0
					x num!: ((addr_of: kernVec) x)
					y num!: ((addr_of: kernVec) y)
					ret <- mcall: x:y 3 vec x y
					mcall: value 2 option ret
				}
			}
			
			firstChar <- {
				_helper getFirstChar: faceOpaque _makeChar
			}
			
			nextChar <- :curChar {
				_helper getNextChar: faceOpaque curChar _makeChar
			}
			
			charmap <- {
				d <- dict hash
				char <- firstChar
				d set: (char charcode) (char glyph)
				while: { (char glyph) != 0u32 } do: {
					char <- nextChar: (char charcode)
					d set: (char charcode) (char glyph)
				}
				d
			}
		} _ptr_init: opaque _makeSlot
	}
	
	_constant <- macro: :name cname {
		quote: (llMessage: name withVars: {
			uintret <- obj_uint32 ptr
		} andCode: {
			uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
			uintret num!: cname
			uintret
		})
	}
	
	_loadFlags <- #{
		_constant: default FT_LOAD_DEFAULT
		_constant: noScale FT_LOAD_NO_SCALE
		_constant: noHinting FT_LOAD_NO_HINTING
		_constant: render FT_LOAD_RENDER
		_constant: noBitmap FT_LOAD_NO_BITMAP
		_constant: verticalLayout FT_LOAD_VERTICAL_LAYOUT
		_constant: forceAuthohint FT_LOAD_FORCE_AUTOHINT
		_constant: pedantic FT_LOAD_PEDANTIC
		_constant: noRecurse FT_LOAD_NO_RECURSE
		_constant: ignoreTransform FT_LOAD_IGNORE_TRANSFORM
		_constant: monochrome FT_LOAD_MONOCHROME
		_constant: linearDesign FT_LOAD_LINEAR_DESIGN
		_constant: noAutohint FT_LOAD_NO_AUTOHINT
		_constant: color FT_LOAD_COLOR
	}
	
	_kerning <- #{
		_constant: default FT_KERNING_DEFAULT
		_constant: unfitted FT_KERNING_UNFITTED
		_constant: unscaled FT_KERNING_UNSCALED
	}
	
	#{
		init <- {
			
			#{
				includeSystemHeader: "ft2build.h"
				includeSystemHeader: FT_FREETYPE_H
				llProperty: library withType: FT_Library
				
				llMessage: _init withVars: {
				} andCode: {
					FT_Init_FreeType: (addr_of: library)
					self
				}
				
				llMessage: libraryOpaque withVars: {
					libOpaque <- cpointer ptr
				} andCode: {
					libOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
					libOpaque val!: library
					libOpaque
				}
				
				faceFromPath:index <- :path :index {
					(_helper newFace: libraryOpaque path index) value: :opaque {
						option value: (_makeFace: opaque)
					} none: {
						option none
					}
				}
				
				llMessage: destroy withVars: {
				} andCode: {
					FT_Done_FreeType: library
					self
				}
			} _init
		}
		
		loadFlags <- { _loadFlags }
		kerning <- { _kerning }
	}
}