# HG changeset patch
# User Michael Pavone <pavone@retrodev.com>
# Date 1427170903 25200
# Node ID 615f23450f8fa63de96f502c152657f3150c5732
# Parent  eb5f1fca9b7818e1d15c9c8318a936e4074566be
Freetype sample: Build texture of glyphs in a more intelligent way

diff -r eb5f1fca9b78 -r 615f23450f8f samples/freetype.tp
--- a/samples/freetype.tp	Mon Mar 23 21:18:26 2015 -0700
+++ b/samples/freetype.tp	Mon Mar 23 21:21:43 2015 -0700
@@ -16,6 +16,232 @@
 		bgra8888
 	] from: (sdl pixelFormats)
 	
+	import: [
+		render
+		linearDesign
+	] from: (freetype loadFlags)
+	
+	makeAtlas <- :renderer face size dpi color {
+		face setCharSize: size res: dpi
+		slot <- face glyphSlot
+		
+		glyphs <- #[]
+		//TODO: Use a bytearray once that has an append method
+		pixels <- #[]
+		foreach: (face charmap) :char glyphIndex {
+			face loadGlyph: glyphIndex flags: (render or linearDesign)
+			pixelStart <- pixels length
+			_width <- slot bitmapWidth
+			_height <- slot bitmapRows
+			pitch <- slot bitmapPitch
+			buffer <- slot bitmapData
+			
+			y <- 0
+			while: { y < _height } do: {
+				x <- 0
+				idx <- y * pitch
+				while: { x < _width } do: {
+					pixels append: (buffer get: idx)
+				
+					x <- x + 1
+					idx <- idx + 1
+				}
+				y <- y + 1
+			}
+			
+			glyphs append: #{
+				width <- _width
+				height <- _height
+				pixelOffset <- pixelStart
+				hAdvance <- slot linearHoriAdvance
+				vAdvance <- slot linearVertAdvance
+				leftOffset <- (slot bitmapLeft)
+				topOffset <- (slot bitmapTop)
+				charCode <- char
+				
+				atlasX <- -1
+				atlasY <- -1
+				
+				<= <- :other {
+					if: height > (other height) {
+						true
+					} else: {
+						if: height < (other height) {
+							false
+						} else: {
+							width >= (other width)
+						}
+					}
+				}
+			}
+		}
+		glyphs sort
+		maxDim <- 2048
+		aWidth <- 128
+		minSize <- maxDim * maxDim
+		minSizeWidth <- -1
+		aHeight <- maxDim
+		
+		while: { aWidth <= maxDim } do: {
+			print: "Checking width: " . aWidth . "\n"
+			curX <- 0
+			curY <- 0
+			minHeight <- 0
+			avail <- glyphs foldr: [] with: :acc val {
+				val | acc
+			}
+			while: { (not: (avail empty?)) && curY <= maxDim } do: {
+				curGlyph <- avail value
+				if: curX + (curGlyph width) < aWidth {
+					if: curY + (curGlyph height) < maxDim {
+						curX <- curX + (curGlyph width)
+						avail <- avail tail
+						if: (curGlyph height) > minHeight {
+							minHeight <- curGlyph height
+						}
+					} else: {
+						curY <- maxDim + 1
+					}
+				} else: {
+					skinny <- option none
+					if: aWidth > curX {
+						availPixels <- aWidth - curX
+						
+						skinny <- avail find: :val {
+							(val width) <= availPixels
+						}
+					}
+					
+					skinny value: :curGlyph {
+						curX <- curX + (curGlyph width)
+						if: (curGlyph height) > minHeight {
+							minHeight <- curGlyph height
+						}
+						avail <- avail filter: :glyph {
+							(glyph charCode) != (curGlyph charCode)
+						}
+					} none: {
+						curY <- curY + minHeight
+						minHeight <- 0
+						curX <- 0
+					}
+				}
+			}
+			if: (avail empty?) {
+				aHeight <- curY + minHeight
+				p2Height <- 1
+				while: { p2Height < aHeight } do: {
+					p2Height <- lshift: p2Height by: 1
+				}
+				
+				size <- aWidth * p2Height
+				if: size < minSize {
+					minSize <- size
+					minSizeWidth <- aWidth
+				}
+			}
+			aWidth <- aWidth * 2
+		}
+		if: minSizeWidth > -1 {
+			print: "Best width: " . minSizeWidth . ", height: " . (minSize / minSizeWidth) . "\n"
+			aWidth <- minSizeWidth
+			aHeight <- minSize / minSizeWidth
+			
+			(renderer createTexture: bgra8888 access: streaming width: aWidth height: aHeight) value: :drawTex {
+				drawTex blendMode!: ((sdl blendModes) blend)
+				//TODO: Use "update" with a static texture
+				drawTex lockRect: (sdl rect: 0 0 size: aWidth aHeight) with: :bytearr pitch {
+					n <- aHeight * pitch
+					i <- 0
+					while: { i < n } do: {
+						bytearr set: i 0u8
+						i <- i + 1
+					}
+					curX <- 0
+					curY <- 0
+					minHeight <- 0
+					avail <- glyphs foldr: [] with: :acc val {
+						val | acc
+					}
+					while: { not: (avail empty?) } do: {
+						curGlyph <- avail value
+						if: curX + (curGlyph width) < aWidth {
+							curGlyph atlasX!: curX
+							curGlyph atlasY!: curY
+							y <- 0
+							dstY <- curY
+							idx <- curGlyph pixelOffset
+							while: { y < (curGlyph height) } do: {
+								dstIdx <- dstY * pitch + curX * 4
+								x <- 0
+								while: { x < (curGlyph width) } do: {
+									//FIXME: This will probably only work on little endian machines
+									bytearr set: dstIdx (pixels get: idx)
+									dstIdx <- dstIdx + 1
+									bytearr set: dstIdx (color r)
+									dstIdx <- dstIdx + 1
+									bytearr set: dstIdx (color g)
+									dstIdx <- dstIdx + 1
+									bytearr set: dstIdx (color b)
+									dstIdx <- dstIdx + 1
+									
+									idx <- idx + 1
+									x <- x + 1
+								}
+								y <- y + 1
+								dstY <- dstY + 1
+							}
+							
+							curX <- curX + (curGlyph width)
+							avail <- avail tail
+							if: (curGlyph height) > minHeight {
+								minHeight <- curGlyph height
+							}
+						} else: {
+							skinny <- option none
+							if: aWidth > curX {
+								availPixels <- aWidth - curX
+								skinny <- avail find: :val {
+									(val width) <= availPixels
+								}
+							}
+							
+							skinny value: :curGlyph {
+								curX <- curX + (curGlyph width)
+								if: (curGlyph height) > minHeight {
+									minHeight <- curGlyph height
+								}
+								avail <- avail filter: :glyph {
+									(glyph charCode) != (curGlyph charCode)
+								}
+							} none: {
+								curY <- curY + minHeight
+								minHeight <- 0
+								curX <- 0
+							}
+						}
+					}
+				}
+				glyphDict <- dict hash
+				foreach: glyphs :idx glyph {
+					glyphDict set: (glyph charCode) glyph
+				}
+				option value: #{
+					texture <- drawTex
+					width <- aWidth
+					height <- aHeight
+					glyphs <- glyphDict
+				}
+			} none: {
+				print: "Failed to create texture for atlas"
+				option none
+			}
+		} else: {
+			print: "Font is too big for a 2048x2048 texture!"
+			option none
+		}
+	}
+	
 	hex2 <- :num {
 		val <- hex: num
 		if: (val length) < 2 {
@@ -31,13 +257,23 @@
 		expectVal <- false
 		optName <- ""
 		path <- ""
+		windowWidth <- 512
+		windowHeight <- 512
 		while: { arg < (args length) } do: {
 			curArg <- args get: arg
 			if: expectVal {
 				if: optName = "--dpi" || optName = "-d" {
 					dpi <- curArg int32
 				} else: {
-					print: "Unrecognized option: " . optName . "\n"
+					if: optName = "--height" {
+						windowHeight <- curArg int32
+					} else: {
+						if: optName = "--width" {
+							windowWidth <- curArg int32
+						} else: {
+							print: "Unrecognized option: " . optName . "\n"
+						}
+					}
 				}
 				expectVal <- false
 			} else: {
@@ -61,84 +297,23 @@
 			}
 			
 			if: (sdl init: (video or timer)) = 0 {
-				(sdl createWindow: "Freetype Test" pos: 0 0 size: 512 512 flags: 0u32) value: :window {
+				(sdl createWindow: "Freetype Test" pos: 0 0 size: windowWidth windowHeight flags: 0u32) value: :window {
 					(window createRenderer: -1 flags: ((window renderOpts) accelerated)) value: :renderer {
 						renderer drawColor!: (sdl r: 255u8 g: 255u8 b: 255u8)
-						(renderer createTexture: bgra8888 access: streaming width: 512 height: 512) value: :drawTex {
-							drawTex blendMode!: ((sdl blendModes) blend)
-							drawTex lockRect: (sdl rect: 0 0 size: 512 512) with: :bytearr pitch {
-								i <- 0
-								n <- charCodes length
-								maxHeight <- 0
-								startY <- 0
-								startX <- 0
-								slot <- face glyphSlot
-								face setCharSize: 12.0 res: dpi
-								while: { i < n && startY < 512 } do: {
-									charCode <- charCodes get: i
-									glyphIndex <- charMap get: charCode else: { 0 }
-									rescode <- face loadGlyph: glyphIndex flags: ((freetype loadFlags) render)
-									if: rescode = 0 {
-										height <- slot bitmapRows
-										width <- slot bitmapWidth
-										if: startX + width > 512 {
-											startY <- startY + maxHeight
-											startX <- 0
-											maxHeight <- 0
-										}
-										
-										if: height > maxHeight {
-											maxHeight <- height
-										}
-										
-										if: height + startY > 512 {
-											startY <- 512
-										} else: {
-											print: "Rendering glyph " . glyphIndex . " to " . startX . ", " . startY . " (" . (startY * pitch  + 4 * startX) . ")\n"
-											print: "Width: " . width . ", Height: " . height . "\n"
-											destY <- startY
-											srcY <- 0
-											srcPitch <- slot bitmapPitch
-											srcBitmap <- slot bitmapData
-											while: { srcY < height } do: {
-												line <- ""
-												destIndex <- destY * pitch + startX * 4
-												srcIndex <- srcY * srcPitch
-												destX <- startX
-												srcX <- 0
-												while: { srcX < width } do: {
-													srcPixel <- srcBitmap get: srcIndex
-													bytearr set: destIndex srcPixel
-													destIndex <- destIndex + 1
-													bytearr set: destIndex 0u8
-													destIndex <- destIndex + 1
-													bytearr set: destIndex 0u8
-													destIndex <- destIndex + 1
-													bytearr set: destIndex 0u8
-													line <- line . " " . (hex2: srcPixel)
-												
-													destX <- destX + 1
-													srcX <- srcX + 1
-													destIndex <- destIndex + 1
-													srcIndex <- srcIndex + 1
-												}
-												print: line . "\n"
-												destY <- destY + 1
-												srcY <- srcY + 1
-											}
-										}
-										startX <- startX + width
-										
-										i <- i + 1
-									} else: {
-										print: "Got error " . rescode . " when loading glyph " . glyphIndex . "\n"
-									}
-								} 
-							}
+						
+						(makeAtlas: renderer face 12.0 dpi (sdl r: 0u8 g: 0u8 b: 0u8)) value: :atlas {
 							continue? <- true
 							while: { continue? } do: {
 								renderer clear
-								drawTex copy
+								y <- 0
+								x <- 0
+								while: { y < (atlas height) } do: {
+									copyWidth <- if: (atlas width) < windowWidth { atlas width } else: { windowWidth }
+									copyHeight <- if: (atlas height) < windowHeight { atlas height } else: { windowHeight }
+									(atlas texture) copyRect: (sdl rect: 0 y size: copyWidth copyHeight) To: (sdl rect: x 0 size: copyWidth copyHeight)
+									y <- y + windowHeight
+									x <- x + copyWidth
+								}
 								renderer present
 								event <- option none
 								while: {
@@ -153,8 +328,7 @@
 								}
 							}
 						} none: {
-							print: "Failed to create texture\n"
-							retcode <- 1
+							retcode <- -1
 						}
 					} none: {
 						print: "Failed to create renderer\n"