view modules/ui.tp @ 347:ff7ea11b4b60

Add length method to executable bytearrays
author Michael Pavone <pavone@retrodev.com>
date Fri, 10 Apr 2015 00:48:12 -0700
parents b8f721bde066
children d61b1f0e1936
line wrap: on
line source
{
    _visibleWindows <- []
    _needsInit <- true
    _initRes <- 0
    _checkInitSDL <- {
        if: _needsInit {
            _initRes <- (sdl init: ((sdl subsystems) video)) = 0
            _needsInit <- true
        }
        _initRes
    }
	
	_applyProps <- :base properties {
		foreach: (object propertiesOf: base) :_ name {
			if: (object does: properties understand?: name) {
				object setProperty: name on: base to: (object sendMessage: name to: properties)
			}
		}
		base
	}
	_ft <- option none
	_getFT <- {
		_ft value: :ft { ft } none: {
			ft <- freetype init
			_ft <- option value: ft
			ft
		}
	}
	
	//TODO: Fix this for multi window
	_atlasDict <- dict hash
	_currentTex <- option none
	_texX <- 0
	_texY <- 0
	_texRowHeight <- 0
	_getFontAtlas <- :path _size  renderer {
		sizes <- _atlasDict get: path else: {
			new <- dict hash
			_atlasDict set: path new
			new
		}
		_getTexture <- :width height {
			_currentTex value: {
				if: _texX + width > 2048 {
					_texY <- _texY + _texRowHeight
					_texRowHeight <- 0
					_texX <- 0
				}
				if: _texY + height > 2048 {
					_currentTex <- renderer createTexture: ((sdl pixelFormats) bgra8888) access: ((sdl textureAccess) streaming) width: 2048 height: 2048
					_currentTex value: :tex {
						tex blendMode!: ((sdl blendModes) blend)
					} none: {}
					_texX <- 0
					_texY <- 0
					_texRowHeight <- 0
				}
				if: _texRowHeight < height {
					_texRowHeight <- height
				}
			} none: {
				_currentTex <- renderer createTexture: ((sdl pixelFormats) bgra8888) access: ((sdl textureAccess) streaming) width: 2048 height: 2048
				_currentTex value: :tex {
					tex blendMode!: ((sdl blendModes) blend)
				} none: {}
			}
			_currentTex
		}
		atlas <- sizes get: _size else: {
			//TODO: Only load face once for all sizes
			a <- ((_getFT: ) faceFromPath: path index: 0) value: :_face {
				_textures <- #[]
				
				_charmap <- _face charmap
				//TODO: Feed in window system DPI or at least make this configurable
				dpi <- 96
				_face setCharSize: _size res: dpi
				_pixelFactor <- ((_face unitsPerEm) f64) * 72.0 / (_size * (dpi f64))
				_emUnits <- _face unitsPerEm
				_glyphs <- dict hash
				_getGlyph <- :codePoint face {
					_glyphs get: codePoint else: {
						flags <- freetype loadFlags
						_charmap ifget: codePoint :_glyphIndex {
							slot <- face glyphSlot
							face loadGlyph: _glyphIndex flags: ((flags render) or (flags linearDesign) or (flags noHinting))
							w <- slot bitmapWidth
							h <- slot bitmapRows
							_advX <- slot linearHoriAdvance
							_advY <- slot linearVertAdvance
							_texture <- _getTexture: w h
							_rect <- sdl rect: _texX _texY size: w h
							_texture value: :tex {
								srcPitch <- slot bitmapPitch
								srcBuffer <- slot bitmapData
								tex lockRect: (sdl rect: _texX _texY size: w h ) with: :dstBuffer dstPitch {
									srcY <- 0
									dstY <- 0
									while: { srcY < h } do: {
										srcX <- 0
										srcIdx <- srcY * srcPitch
										dstIdx <- dstY * dstPitch
										while: { srcX < w } do: {
											//Set destination pixel to white with the source pixel as alpha
											//This allows text color to be set using colorMod! on the texture
											dstBuffer set: dstIdx (srcBuffer get: srcIdx)
											dstBuffer set: (dstIdx + 1) 255u8
											dstBuffer set: (dstIdx + 2) 255u8
											dstBuffer set: (dstIdx + 3) 255u8
											
											srcX <- srcX + 1
											srcIdx <- srcIdx + 1
											dstIdx <- dstIdx + 4
										}
										
										srcY <- srcY + 1
										dstY <- dstY + 1
									}
								}
							} none: {}
							_texX <- _texX + w
							_leftOff <- slot bitmapLeft
							_topOff <- slot bitmapTop
							g <- #{
								advanceX <- { _advX }
								advanceY <- { _advY }
								atlasRect <- { _rect }
								
								glyphIndex <- { _glyphIndex }
								drawAt:color <- :x y :color {
									_texture value: :tex {
										tex colorMod!: color
										tex copyRect: _rect To: (sdl rect: x+_leftOff y-_topOff size: (_rect w) (_rect h))
									} none: {}
								}
							}
							_glyphs set: codePoint g
							g
						} else: {
							//get fallback
							_getGlyph: 0u32 face
						}
					}
				}
				
				_getGlyphs <- :str face {
					i <- 0
					lines <- #[]
					curline <- #[]
					nl <- ("\n" byte: 0) uint32
					while: { i < (str byte_length) } do: {
						//TODO: Unicode
						codePoint <- (str byte: i) uint32
						if: codePoint = nl {	
							lines append: curline
							curline <- #[]
						} else: {
							glyph <- _getGlyph: codePoint face
							curline append: glyph
						}
						i <- i + 1
					}
					lines append: curline
					lines
				}
				_iterateGlyphs:leading:using <- :str :leading :fun {
					lines <- _getGlyphs: str _face
					y <- 0.0
					maxX <- 0.0
					print: "Leading: " . leading . ", EM units: " . _emUnits . "\n"
					leading <- leading * (_emUnits f64) / _size
					foreach: lines :_ glyphs {
						x <- 0.0
						baseline <- y + (_emUnits f64)
						foreach: glyphs :_ glyph {
							fun: glyph x baseline
							x <- x + ((glyph advanceX) f64)
							//baseline <- baseline + ((glyph advanceY) f64)
							//TODO: kerning
						}
						y <- y + leading
						if: x > maxX {
							maxX <- x
						}
					}
					//convert font units into pixels
					x <- (maxX / _pixelFactor + 0.5) truncInt32
					y <- (y / _pixelFactor + 0.5) truncInt32
					vec x: x y: y
				}
				option value: #{
					stringSize:leading <- :str :leading {
						_iterateGlyphs: str leading: leading using: :glyph x y {}
					}
					
					drawString:at:color:leading <- :str :xpos ypos :color :lead {
						_iterateGlyphs: str leading: lead using: :glyph x y {
							x <- ((x / _pixelFactor + 0.5) truncInt32) + xpos
							y <- ((y / _pixelFactor + 0.5) truncInt32) + ypos
							glyph drawAt: x y color: color
						}
					}
				}
			} none: {
				option none
			}
			sizes set: _size a
			a
		}
	}
	#{
        import: [
            r:g:b
            r:g:b:a
        ] from: sdl
        _styles <- []
		window <- :properties {
            _wind <- option none
            _renderer <- option none
			
			
            base <- #{
                title <- "Window"
                width <- 640
                height <- 480
                x <- 0
                y <- 0
                color <- (ui r: 255u8 g: 255u8 b: 255u8)
                children <- #[]
                
                show <- {
                    if: (_checkInitSDL: ) {
                        _wind <- sdl createWindow: title pos: x y size: width height flags: 0u32
                        _wind value: :window {
                            _renderer <- window createRenderer: -1 flags: ((window renderOpts) accelerated)
							layout:
                            draw:
                        } none: {
                            false
                        }
                    }
                }
				
				layout <- {
					_renderer value: :renderer {
						yPos <- 0
						xPos <- 0
						rowMaxHeight <- 0
						foreach: children :_ child {
							softMax <- (width - xPos)
							child softMaxWidth: softMax maxWidth: width maxHeight: (height - yPos) renderer: renderer
							if: (child width) > softMax {
								yPos <- yPos + rowMaxHeight
								xPos <- 0
								rowMaxHeight <- 0
							}
							child x!: xPos
							child y!: yPos
							xPos <- xPos + (child width)
							if: (child height) > rowMaxHeight {
								rowMaxHeight <- (child height)
							}
							if: xPos >= width {
								yPos <- yPos + rowMaxHeight
								xPos <- 0
								rowMaxHeight <- 0
							}
						}
					} none: {}
				}
				
				draw <- {
					print: "Draw!\n"
					_renderer value: :renderer {
						print: "Rendering!\n"
						renderer drawColor!: color
						renderer clear
						
						foreach: children :_ child {
							child draw: renderer
						}
						renderer present
						true
					} none: { false }
				}
                
                styles <- { _styles }
                
                styles! <- :newstyles{
                    //TODO: apply styles
                    _styles <- newstyles
                }
            }
            _applyProps: base properties
		}
		
		text <- :properties {
			_fontSize <- 12.0
			_leading <- 15.0
			_explicitLeading <- false
			_applyProps: #{
				text <- ""
				//TODO: replace this with font family and style once fontconfig is hooked up
				font <- "/usr/share/fonts/truetype/droid/DroidSans.ttf"
				fontSize <- { _fontSize }
				fontSize! <- :newSize {
					_fontSize <- newSize
					if: (not: _explicitLeading) {
						_leading <- newSize * 1.25
					}
				}
				leading <- { _leading }
				leading! <- :newLeading {
					_explicitLeading <- true
					_leading <- newLeading
				}
				color <- (ui r: 0u8 g: 0u8 b: 0u8)
				width <- -1
				height <- -1
				x <- 0
				y <- 0
				
				softMaxWidth:maxWidth:maxHeight:renderer <- :softMax :maxWidth :maxHeight :renderer {
					(_getFontAtlas: font fontSize renderer) value: :atlas {
						//TODO: word wrap
						bbox <- atlas stringSize: text leading: _leading
						width <- bbox x
						height <- bbox y
						print: "Text: " . text . " has size: " . width . ", " . height . "\n"
					} none: {
					}
				}
				
				draw <- :renderer {
					(_getFontAtlas: font fontSize renderer) value: :atlas {
						print: "Drawing: " . text . " at " . x . ", " . y . "\n"
						atlas drawString: text at: x y color: color leading: _leading
					} none: {
					}
				}
			} properties
		}
		
		image <- :properties {
			_texture <- option none
			_applyProps: #{
				source <- ""
				width <- -1
				height <- -1
				x <- 0
				y <- 0
				
				softMaxWidth:maxWidth:maxHeight:renderer <- :softMax :maxWidth :maxHeight :renderer {
					_texture value: :_ {
					} none: {
						(sdl loadBMP: source) value: :surface {
							(surface asTexture: renderer) value: :texture {
								_texture <- option value: texture
								width <- texture width
								height <- texture height
								if: (width > maxWidth) {
									width <- maxWidth
								}
								if: (height > maxHeight) {
									height <- maxHeight
								}
							} none: {
								width <- 0
								height <- 0
							}
						} none: {
							print: "Failed to load " . source . "\n"
							//Should this have some kind of placeholder as a fallback?
							width <- 0
							height <- 0
						}
					}
				}
				
				draw <- :_ {
					_texture value: :texture {
						print: "Rendering bitmap to " . x . ", " . y . ", size: " . width . ", " . height . "\n"
						texture copyTo: (sdl rect: x y size: width height)
					} none: {
					}
				}
			} properties
		}
        
        enterEventLoop <- {
            continue? <- true
            
            _handlers <- dict hash
            _handlers set: ((sdl eventTypes) quit) :event {
                continue? <- false
            }
            _handlers set: ((sdl eventTypes) window) :event {
                if: (event event) = ((sdl windowEventTypes) exposed) {
					foreach: _visibleWindows :_ wind {
						print: "Redrawing window\n"
						wind draw
					}
				}
            }
            while: { continue? } do: {
                (sdl waitEvent) value: :event {
					_handlers ifget: (event type) :handler {
						handler: event
					} else: {
						print: "Unhandled event type: " . (event type) . "\n"
					}
				} none: {}
            }
        }
	}
}