implementation module osfont


import	StdBool, StdClass, StdEnum, StdReal
import	clCrossCall_12, pictCCall_12
from	clCCall_12		import winMakeCString, winGetCString, :: CSTR, winGetVertResolution
from	StdPictureDef	import :: FontName, :: FontSize, :: FontStyle, BoldStyle, ItalicsStyle, UnderlinedStyle
from	commondef		import fatalError, isBetween, minmax, stateMap
from	ostypes			import :: OSPictContext, :: HDC


::	Font
	=	{	fontdef	:: !OSFontDef	// The font requested by the program
		,	fontimp	:: !OSFont		// The font selected  by the system
		}
::	OSFont
	=	{	osfontname	:: !String	// Name of the font
		,	osfontstyles:: !Int		// Style variations of the font
		,	osfontsize	:: !Int		// Size of the font
		}
::	OSFontDef
	:==	(	!String					// Name of the font
		,	![String]				// Style variations of the font
		,	!Int					// Point size of the font
		)

instance == OSFont where
	(==) :: !OSFont !OSFont -> Bool
	(==) f1 f2 = f1.osfontsize==f2.osfontsize && f1.osfontstyles==f2.osfontstyles && f1.osfontname==f2.osfontname

//	Font constants:
osSerifFontDef           :: OSFontDef;	osSerifFontDef			= ("Serif",      [],10)
osSansSerifFontDef       :: OSFontDef;	osSansSerifFontDef		= ("Sans",       [],10)
osSmallFontDef           :: OSFontDef;	osSmallFontDef			= ("Sans",       [],7 )
osNonProportionalFontDef :: OSFontDef;	osNonProportionalFontDef= ("Monospace",  [],10)
osSymbolFontDef          :: OSFontDef;	osSymbolFontDef			= ("Symbol",     [],10)


osSelectfont :: !OSFontDef !*OSToolbox -> (!Bool,!Font,!*OSToolbox)
osSelectfont fdef=:(fName,fStyles,fSize) tb
	= (True,{fontdef=fdef,fontimp=fimp},tb)
where
	fimp	= {osfontname=fName,osfontstyles=sStyle2IStyle fStyles,osfontsize=fSize}

osDefaultfont :: !*OSToolbox -> (!Font,!*OSToolbox)
osDefaultfont tb
	= ({fontdef=def,fontimp=imp},tb)
where
	def		= (name,styles,size)
	imp		= {osfontname=name,osfontstyles=sStyle2IStyle styles,osfontsize=size}
	name	= "Sans"
	styles	= []
	size	= 10

osDialogfont :: !*OSToolbox -> (!Font,!*OSToolbox)
osDialogfont tb
	= ({fontdef=def,fontimp=imp},tb)
where
	def		= (name,styles,size)
	imp		= {osfontname=name,osfontstyles=sStyle2IStyle styles,osfontsize=size}
	name	= "Sans"
	styles	= []
	size	= 8

osFontgetdef :: !Font -> OSFontDef
osFontgetdef {fontdef}
	= fontdef

osFontgetimp :: !Font -> OSFont
osFontgetimp {fontimp}
	= fontimp

sStyle2IStyle :: ![FontStyle] -> Int
sStyle2IStyle styles
	= s2i styles 0
where
	s2i []                         i = i
	s2i [ BoldStyle       : rest ] i = s2i rest (i bitor iBold)
	s2i [ ItalicsStyle    : rest ] i = s2i rest (i bitor iItalic)
	s2i [ UnderlinedStyle : rest ] i = s2i rest (i bitor iUnderline)
 	s2i [ _               : rest ] i = s2i rest i

iStyle2SStyle :: !Int -> [FontStyle]
iStyle2SStyle istyle
	= idtofontstyles` istyle [iBold,iItalic,iUnderline,iStrikeOut]
where
	idtofontstyles` :: !Int ![Int] -> [String]
	idtofontstyles` 0 _
		= []
	idtofontstyles` istyle [styleflag:styleflags]
		| notStyleFlag	= styles
		| otherwise		= [style:styles]
	where
		notStyleFlag	= istyle bitand styleflag == 0
		styles			= idtofontstyles` (istyle-styleflag) styleflags
		style			= if (styleflag==iBold)      BoldStyle
						 (if (styleflag==iItalic)    ItalicsStyle
						 (if (styleflag==iUnderline) UnderlinedStyle
						                             (fatalError "iStyle2SStyle" "osfont"
																 "unmatched styleflag value ("+++toString styleflag+++")"
													 )))
	idtofontstyles` _ _
		= []


osFontnames :: !*OSToolbox -> (![String], !*OSToolbox)
osFontnames tb
	# getFontNamesCci		= {ccMsg=CcRqGETFONTNAMES,p1=0,p2=0,p3=0,p4=0,p5=0,p6=0}
	# (_,unsortednames,tb)	= issueCleanRequest fontnamesCallback getFontNamesCci [] tb
	= (sortAndRemoveDuplicates unsortednames,tb)
where
	fontnamesCallback :: !CrossCallInfo ![FontName] !*OSToolbox -> (!CrossCallInfo,![String],!*OSToolbox)
	fontnamesCallback cci names os
		# (newname,os) = winGetCString cci.p1 os
		= (return0Cci,[newname:names],os)

sortAndRemoveDuplicates :: !u:[a] -> u:[a] | Ord a
sortAndRemoveDuplicates [e:es]
	= insert e (sortAndRemoveDuplicates es)
where
	insert :: a !u:[a] -> u:[a] | Ord a
	insert a list=:[b:x]
		| a<b		= [a:list]
		| a>b		= [b:insert a x]
		| otherwise	= list
	insert a _
		= [a]
sortAndRemoveDuplicates _
	= []


osFontstyles :: !String !*OSToolbox -> (![String],!*OSToolbox)
osFontstyles fname tb
	= ([BoldStyle,ItalicsStyle,UnderlinedStyle],tb)

osFontsizes :: !Int !Int !String !*OSToolbox -> (![Int],!*OSToolbox)
osFontsizes between1 between2 fname tb
	# (textptr,tb)			= winMakeCString fname tb
	  getFontSizesCci		= {ccMsg=CcRqGETFONTSIZES,p1=textptr,p2=0,p3=0,p4=0,p5=0,p6=0}
	# (_,unsortedsizes,tb)	= issueCleanRequest fontSizesCallback getFontSizesCci [] tb
	= (sortAndRemoveDuplicates unsortedsizes,tb)
where
	(low,high)	= minmax between1 between2
	
	fontSizesCallback :: !CrossCallInfo ![FontSize] !*OSToolbox -> (!CrossCallInfo,![FontSize],!*OSToolbox)
	fontSizesCallback cci=:{p1=size,p2=0} sizes tb
		= (return0Cci,newsizes,tb)
	where
		pts		= height2Points size
		newsizes= if (isBetween pts low high)
					 [pts:sizes]
					 sizes
	fontSizesCallback _ _ tb
		= (return0Cci,[low..high],tb)

height2Points :: !Int -> Int
height2Points h
	= toInt points
where
	dpi		= toReal winGetVertResolution
	phfactor= dpi / 72.0
	points	= toReal h / phfactor

/* XXX MW: probably not called anywhere
points2Height :: !Int -> Int
points2Height p
	= toInt height
where
	dpi		= toReal winGetVertResolution
	phfactor= dpi / 72.0
	height	= toReal p * phfactor
*/

osGetfontcharwidths :: !Bool !OSPictContext ![Char] !Font !*OSToolbox -> (![Int], !*OSToolbox)
osGetfontcharwidths hdcPassed maybeHdc chars {fontimp={osfontname,osfontstyles,osfontsize}} tb
	= stateMap (\c tb->winGetCharWidth c (osfontname,osfontstyles,osfontsize) (toInt hdcPassed) maybeHdc tb) chars tb

osGetfontstringwidth :: !Bool !OSPictContext !String !Font !*OSToolbox -> (!Int, !*OSToolbox)
osGetfontstringwidth hdcPassed maybeHdc string {fontimp={osfontname,osfontstyles,osfontsize}} tb
	= winGetStringWidth string (osfontname,osfontstyles,osfontsize) (toInt hdcPassed) maybeHdc tb

osGetfontstringwidths :: !Bool !OSPictContext ![String] !Font !*OSToolbox -> (![Int], !*OSToolbox)
osGetfontstringwidths hdcPassed maybeHdc strings {fontimp={osfontname,osfontstyles,osfontsize}} tb
	= stateMap (\s tb->winGetStringWidth s (osfontname,osfontstyles,osfontsize) (toInt hdcPassed) maybeHdc tb) strings tb

osGetfontmetrics :: !Bool !OSPictContext !Font !*OSToolbox -> (!(!Int,!Int,!Int,!Int),!*OSToolbox)
osGetfontmetrics hdcPassed maybeHdc {fontimp={osfontname,osfontstyles,osfontsize}} tb
	# (ascent,descent,maxwidth,leading,tb) = winGetFontInfo (osfontname,osfontstyles,osfontsize) (toInt hdcPassed) maybeHdc tb
	= ((ascent,descent,leading,maxwidth),tb)