Help on an error - bgi graphics, function plot modules
Help on an error - bgi graphics, function plot modules
the test program consists of 2 module and the test program. everything works, but the sine curve does not appear in the graph at the correct place. unfortunatly i can't debug the global values with the beta versions of the compiler. maybe some one can spot the error.
Re: Help on an error - bgi graphics, function plot modules
Code: Select all
DeclareModule MINIBGI
EnableExplicit
; update constants
#UpdateOff = 0
#UpdateOn = 1
#UpdateNow = 2
; clipping constants
#ClipOn = 1
#ClipOff = 0
; raster operation constants
#CopyPut = 0
#XorPut = 1
#OrPut = 2
#AndPut = 3
#NotPut = 4
#NotOrPut = 5
#InvBitOrPut = 6
#InvScrAndPut = 7
#TransPut = 8
#MaskPut = 9
#BkgPut = 10
#NormalPut = #CopyPut
; drawing modes on screen
#CopyMode = 0
#XorMode = 1
#OrMode = 2
#AndMode = 3
#NotMode = 4
#NotScrMode = 5
#NotXorMode = 6
#NotOrMode = 7
#NotAndMode = 8
#InvColAndMode = 9
#InvColOrMode = 10
#InvScrAndMode = 11
#InvScrOrMode = 12
#BlackMode = 13
#WhiteMode = 14
#EmptyMode = 15
#TRANSPARENT_ = $00
#OPAQUE_ = 16
; drawing style For lines
#SolidLn = 0
#DottedLn = 1
#DashDotLn = 2
#DashedLn = 3
#DashDotDotLn = 4
#UserBitLn = 5
#NullLn = 6
; thick constants For lines
#NormWidth = 1
#DoubleWidth = 2
#TripleWidth = 3
#QuadWidth = 4
#ThickWidth = #TripleWidth
; filling patterns
#EmptyFill = 0
#SolidFill = 1
#LineFill = 2
#ColFill = 3
#HatchFill = 4
#SlashFill = 5
#BkSlashFill= 6
#XHatchFill = 7
#UserFill = 8
#NoFill = 9
; Bar3D constants
#TopOn = 1
#TopOff = 0
; flood mode constants
#BorderFlood = 0
#SurfaceFlood = 1
; justify constants For text
#LeftText = 0
#CenterText = 1
#RightText = 2
#TopText = 0
#BottomText = 1
#BaselineText = 2
; direction constants For text
#HorizDir = 0
#VertDir = 90
; font constants For text
#CourierNewFont = 0
#MSSansSerifFont = 1
#TimesNewRomanFont= 2
#ArialFont = 3
#DefaultFont = #CourierNewFont
#ItalicFont = $1000
#UnderlineFont = $0100
#BoldFont = $0010
; Symbols for graphs
#SYMBOLRECTANGLE = 1
#SYMBOLTRIANGLE = 2
#SYMBOLDIAMOND = 3
#SYMBOLCROSS = 4
#SYMBOLXCROSS = 5
#SYMBOLNONE = 0
Structure ViewPortType
x1.w
y1.w
x2.w
y2.w
clip.l ; BOOLEAN
EndStructure
Structure PointType
x.l
y.l
EndStructure
Structure ThreeDPointType
x.d
y.d
z.d
EndStructure
Structure LineSettingsType
linestyle.w
pattern.w
thickness.w
EndStructure
Structure ArcCoordsType
x.l
y.l
xstart.i
ystart.i
xend.i
yend.i
EndStructure
Structure FillSettingsType
pattern.w
color.l
EndStructure
Structure TextSettingsType
font.w
direction.w
charsize.w
horiz.w
vert.w
EndStructure
; Global grResult.i=-1
Macro INC(i,j=1)
i + j
EndMacro
Macro DEC(i,j=1)
i - j
EndMacro
; initialization exported routines
; Clears the entire graphics screen using ClearViewPort routine. See that routine For details. Current pointer is reset
; at (0,0), that is top-left corner of the screen.
Declare ClearDevice()
; Closes the graphics window And releases all resources related To it. The parent console window is shown again in foreground
; (If any). You can Restore back the graphics window using SetGraphMode Or InitGraph.
Declare CloseGraph()
; Use CloseGraph To close the graphics window.
Declare.i InitGraph(windownumber.i, Winx.l, Winy.l, title.s)
; Sets the dimensions of the graphics window To be created by InitGraph. In this Case you must use mCustom graphics mode. (width)
; is the width And (height) is the height in pixels of the window client area. See InitGraph For more details.
; screen management exported routines
; Clears the current viewport. The current background color is used As filling color. The pointer is set at (0,0),
; that is top-left corner of the viewport. See also SetViewPort And SetBkColor For more details.
Declare ClearViewPort()
Declare GetAspectRatio(*xasp.word, *yasp.word)
; Returns the maximum x-coordinate (horizontal) in pixels. This equals the client area width minus 1. Maximum is placed on the
; right side.
Declare.i GetMaxX()
; Returns the maximum y-coordinate (vertical) in pixels. This equals the client area height minus 1. Maximum is placed on the
; bottom side.
Declare.i GetMaxY()
; Returns the current viewport And clipping settings in (viewport). You can change these settings using SetViewPort.
Declare GetViewSettings(*viewport.ViewPortType)
; Returns the x-coordinate of the current position of the graphical pointer in pixels. It ranges between 0 And GetMaxX.
; It increases from left To right.
Declare.i GetXX()
; Returns the y-coordinate of the current position of the graphical pointer in pixels. It ranges between 0 And GetMaxY.
; It increases from top To bottom.
Declare.i GetYY()
; Sets the aspect ratio of the screen To the ratio given by xasp/yasp. It affects only routines For circular shapes. Does Not
; have a practical use other than backward compatibility With BP. Default values are (10000,10000). See also GetAspectRatio.
Declare SetAspectRatio(xasp,yasp.i)
; Sets the current output viewport To the rectangle defined by the top-left corner (x1,y1) And the bottom-right corner (x2,y2).
; If (clip) is true, anything drawn outside the viewport will be clipped (Not drawn). Coordinates specified after this call are
; relative To the top-left corner of the viewport. Cursor position is reset To (0,0). The following clipping constants are defined:
; ClipOn = #true
; ClipOff = #false
Declare SetViewPort(x1.l,y1.l,x2.l,y2.l, clip.l) ; BOOLEAN
; It specifies what binary operation is performed when drawing on screen. Argument (writemode) has two components. First
; component is the foreground mix mode. It affects contours (including lines) And filled shapes (excluding Bar). Can be one of
; the following pre-defined constants:
; CopyMode - pixels are simply copied onto the screen
; XorMode - pixels are combination of the drawing color And screen color, but Not in both (logical XOr)
; OrMode - pixels are combination of the drawing color And screen color (logical Or)
; AndMode - pixels are combination of the colors common To both the drawing And screen (logical And)
; NotMode - pixels are the inverse of the drawing color (logical Not)
; NotScrMode - pixels are the inverse of the screen color
; NotXorMode - pixels are the inverse of the XorMode color
; NotOrMode - pixels are the inverse of the OrMode color
; NotAndMode - pixels are the inverse of the AndMode color
; InvColAndMode - pixels are combination of the colors common To both the screen And the inverse of drawing color
; InvColOrMode - pixels are combination of the screen color And the inverse of drawing color
; InvScrAndMode - pixels are combination of the colors common To both the drawing And the inverse of screen color
; InvScrOrMode - pixels are combination of the drawing color And the inverse of screen color
; BlackMode - pixels are always 0
; WhiteMode - pixels are always 1
; EmptyMode - screen pixels remain unchanged
; Second component is the background mix mode. It affects only texts. Can be one of the following two pre-defined constants:
; Transparent - screen remains untouched (As in BP graph unit)
; Opaque - screen is filled With the current background color before the text is drawn
; Argument (writemode) is an Or-ed combination of the foreground And background mix modes. By Default it equals CopyMode Or Transparent.
; SetWriteMode does Not perform well on palette-based drivers, especially If the palette was Not retrived by GetSystemPalette
; routine. Anyway, because the palette is just a logical one you must use UpdateGraph routine To assure that the screen has the
; same color composition As the active page.
; You can use InvertRect To perform logical Not operations over the screen content.
Declare SetWriteMode(writemode.l)
Declare.i GetDC()
; color management exported routines
; Returns the current background color. This is a palette entry For palette-based drivers And an absolute RGB color For
; non-palette driver. Use SetBkColor To set a new color.
Declare.l GetBkColor()
; Returns the current drawing color. This is a palette entry For palette-based drivers And an absolute RGB color For
; non-palette driver. Use SetColor To set a new color.
Declare.l GetColor()
; Returns the highest color which can be set With SetColor Or other routines that accept colors. Depending on palette, this
; color is Not always White. All colors between 0 And GetMaxColor are guarantied To be valid.
; it equals FFFFFFH.
Declare.l GetMaxColor()
; Gets the pixel color of the point at position (x,y). This is a palette entry For palette-based drivers And an absolute RGB
; color For non-palette driver. To set a new color For the pixel use PutPixel.
Declare.l GetPixel(x.l,y.l)
; Returns the (Red,Green,Blue) intensity components of the color (color) in (r), (g), (b) variables. Their values range
; between 0 And 255. For example, Black returns (0,0,0). See also GetRGBColor. Parameter (color) is a palette index in
; palette-based drivers And a true RGB color For the non-palette driver.
Declare GetRGBComponents(color.l, *r.long,*g.long,*b.long, *t.long=#Null)
; Returns a maximum of 256 colors from Windows system palette. This is the palette initialized by the operating system at
; start-up. You have no guaranty that this palette is the same across all systems. In fact, it"s not.
;Declare GetSystemPalette(*palette.PaletteType)
; Sets the background color To (color). Check SetColor To learn about color values.
; The background color is the color used To clear portions of the screen (Or the entire viewport). It is also used As dual color
; in filling patterns. SetBkColor affects only subsequent drawings. Default color is Black.
Declare SetBkColor(color.l)
; Sets the foreground color To (color). For palette-based drivers the value of (color) is an index into the palette. For
; non-palette driver (color) stores a 24 bits RGB value encoded in hexadecimal form. The low-order byte contains a value For
; the relative intensity of red, the second byte contains a value For green And the third byte contains a value For blue
; (ex 0000FFH is Red). In both cases, pre-defined color names can be used instead of pure numbers. Consult InitGraph about graphics
; drivers And the section Alphabetical color names. See GetNamesPalette routine For more details on colors.
; The foreground color is the color used For drawing contours, lines And text. Other primitives have different ways To specify
; the color. Default color is White.
Declare SetColor(color.l)
; drawing primitives exported routines
; Draws part of a circle With center at (x,y), radius (radius), starting from angle (start), stopping at angle (stop).
; These angles are measured counter-clockwise. It uses current foreground color. To draw an entire circle use Circle.
Declare Arc(x.l,y.l, start.l,stop.l,radius.l)
; Draws a complete circle With center at (x,y) And radius (radius). To draw part of a circle use Arc.
; Circle is a particular Case of Ellipse.
Declare Circles(x.l,y.l, radius.l)
; Draws one Or more cubic Bezier curves, using the current foreground color. A Bezier curve is defined by two endpoints And
; two control points in between. A number of 3N+1 vertices will Define exactly N Bezier curves. The arguments are the same As in
; DrawPoly. It can be used To draw irregular curves, but a particular Case is a rotated ellipse. See RotEllipse For details.
Declare DrawBezier(nrpoints.i, Array *polypoints.PointType(1))
; Draws a polygon With (nrpoints) corner points, using the current foreground color And line style. Argument (polypoints)
; should be an Array of type PointType containing at least (nrpoints) records. No check is performed. The last corner point is
; Not drawn. It is usually faster that using several LineTo calls.
Declare DrawPoly(nrpoints.i, Array *polypoints.PointType(1))
; Draws part of an ellipse With center at (x,y). Arguments (xradius) And (yradius) are the horizontal And vertical radii of the
; ellipse, (start) And (stop) are the starting And stopping angles of the arc of the ellipse. They are measured counter-clockwise
; from the x-axis (3 o’clock is equal To 0 degrees). It uses current foreground color. To draw part of a circle use Arc.
; To draw a rotated ellipse use RotEllipse.
Declare Ellipses(x.l,y.l, start.l,stop.l,xradius.l,yradius.l)
Declare GetArcCoords(*arccoords.ArcCoordsType)
; Returns the current line settings in (lineinfo). That is, line style, pattern And thickness, As set by SetLineStyle.
Declare GetLineSettings(*lineinfo.LineSettingsType)
; Draws a line starting from (x1,y1) To (x2,y2), using the current foregroung color And line style. The current position is
; moved To (x2,y2). See LineTo For more details.
Declare Lines(x1.l,y1.l,x2.l,y2.l)
; Draws a line starting from the current pointer position To the Point (dx,dy), relative To the current position, using the
; current foreground color And line style. The current position is moved To the endpoint of the line. See LineTo For more details.
Declare LineRel(dx.l,dy.l)
; Draws a line starting from the current pointer position To the Point (x,y), using the current foregroung color And line style.
; The current position is moved To (x,y).
; Use SetLineStyle routine To set the line attributes And SetColor To set its color. Use MoveTo To change the current pointer
; position. To draw a line With absolute coordinates use Line routine instead.
Declare LineTo(x.l,y.l)
; Moves the pointer To coordinates (dx,dy), relative To the current pointer position. See MoveTo For more details.
Declare MoveRel(dx.l,dy.l)
; Moves the pointer To coordinates (x,y) which are viewport-relative. See SetViewPort For more details. Only the following
; routines use Or move the current pointer:
; ClearDevice
; ClearViewPort
; GraphDefaults
; Line
; LineRel
; LineTo
; MoveRel
; MoveTo
; OutText
; OutTextXY
; SetViewPort
; No check is made regarding coordinates range.
Declare MoveTo(x.l,y.l)
; Puts a point at position (x,y) using color (color). Check SetColor To learn about color values. Use GetPixel To retrive a
; pixel color.
Declare PutPixel(x.l,y.l, color.l)
; Draws a rectangle defined by the top-left corner (x1,y1) And the bottom-right corner (x2,y2). It uses the current foreground
; color And line style. To draw a filled rectangle use FillRect.
; Rectangle is a particular Case of DrawPoly.
Declare Rectangle(x1.l,y1.l,x2.l,y2.l)
; Draws a rotated ellipse With center at (x,y). Arguments (xradius) And (yradius) are the horizontal And vertical radii of the
; ellipse, (rot) defines the rotation angle measured counter-clockwise in degrees. It uses current foreground color. It is
; implemented using DrawBezier.
Declare RotEllipse(x.l,y.l,rot.i, xradius.i,yradius.i)
; Sets the drawing style For lines. The (linestyle) is one of the following constants:
; SolidLn - solid line
; DashedLn - dashed line
; DottedLn - dotted line
; DashDotLn - alternating dashes And dots line
; DashDotDotLn - dashes And double dots line
; UserBitLn - user defined line
; NullLn - invisible line
; If UserBitLn is specified then (pattern) should contain the 16-bit pattern. In all another cases (pattern) is ignored. The
; parameter (thickness) indicates how thick the line should be:
; NormWidth - one pixel width
; DoubleWidth - two pixels width
; TripleWidth - three pixels width
; QuadWidth - four pixels width
; ThickWidth=TripleWidth
; If (thickness) <> NormWidth then (linestyle) is ignored And the line is drawn solid, due To Windows GDI limitations.
; (thickness) is ignored For UserBitLn style because of missing implementation. Use SetColor To set the line color.
Declare SetLineStyle(linestyle.i,pattern.l,thickness.i)
; filled drawings exported routines
; Draws And fills a rectangle With opposite corners at (x1,y1) And (x2,y2), using the current fill style And color.
; This rectangle has no border. Use FillRect To draw a filled rectangle With border.
Declare Bar(x1.l,y1.l,x2.l,y2.l)
; Draws And fills a 3-dimensional bar With opposite corners of the front facet at (x1,y1) And (x2,y2). It uses the
; current foreground color. Only front facet is filled With the current fill style And color. Argument (depth) specifies
; the number of pixels used To show the depth of the bar. If (top) is true, then a 3-dimensional top is drawn.
; Its pre-defined values are
; TopOn = true
; TopOff = false
; Use Bar To draw a 2-dimensional bar.
Declare Bar3D(x1.l,y1.l,x2.l,y2.l, depth.l, top.l) ; BOOLEAN
; Draws And fills a chord (a region bounded by the intersection of an ellipse And a line segment - called a secant).
; It uses the current foreground color And fill style. The arguments have the same meaning As in Ellipse. To draw a
; sector of an ellipse use Sector.
Declare Chord(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
; Draws And fills an entire ellipse With center at (x,y). Arguments (xradius) And (yradius) are the horizontal And vertical
; radii of the ellipse. It uses the current foreground color And fill style. To draw a sector of an ellipse use Sector.
Declare FillEllipse(x.l,y.l,xradius.i,yradius.i)
; Draws And fills a polygon, using the current foreground color, line And fill style. The arguments are the same As in DrawPoly.
; The polygon is closed automatically by drawing a line from the last vertex To the first.
Declare FillPoly(nrpoints.i, Array *polypoints.PointType(1))
; Draws And fills a rectangle, using the current foreground color, line And fill style. The arguments are the same As in Rectangle.
; To draw a borderless rectangle use Bar instead.
; FillRect is a particular Case of FillPoly.
Declare FillRect(x1.l,y1.l,x2.l,y2.l)
; Fills a region surrounding the Point (x,y) Until a color-condition is met. This condition depends on (color) And the flood mode.
; This mode is set With SetFloodMode routine.
; There are some reasons this routine might fail:
; (1) the filling could Not be completed (out of memory) - unlikely
; (2) the specified point has the boundary color specified by the (color)
; parameter (in BorderFlood mode)
; (3) the specified point does Not have the color specified by (color)
; parameter (in SurfaceFlood mode)
; (4) the point is outside the current viewport, that is, it is Not visible
; See SetFloodMode For details.
Declare FloodFill(x.l,y.l, color.l)
; Returns in (fillpattern) the current fill-pattern Array. This was set using SetFillPattern routine.
Declare GetFillPattern(Array *fillpatternn.byte(1)) ;FillPatternType
; Returns the current fill-settings in (fillinfo). This Structure contains the fill pattern And color, As set by SetFillStyle routine
Declare GetFillSettings(*fillinfo.FillSettingsType)
; Performs a logical Not operation on the color values For each pixel in the specified rectangle defined by coordinates (x1,y1,x2,y2).
; On monochrome driver, InvertRect makes white pixels black And black pixels white. On color drivers, the inversion depends on
; how colors are generated. Calling InvertRect twice For the same rectangle restores the display To its previous colors. It does
; Not perform well on palette-based drivers. See also SetWriteMode.
Declare InvertRect(x1.l,y1.l,x2.l,y2.l)
; Draws And fills a circular sector (a region bounded by the intersection of a circle And two radials - called pie slice).
; It uses the current foreground color And fill style. The arguments have the same meaning As in Arc. To draw an entire disk
; use FillEllipse.
; PieSlice is a particular Case of Sector
Declare PieSlice(x.l,y.l, start.i,stop.i,radius.l)
; Draws And fills a rectangle With rounded corners, using the current foreground color, fill style And color. The argument (r)
; is the radius of a circle used To draw the corners. The other parameters are the same As in Rectangle.
Declare RoundRect(x1.l,y1.l,x2.l,y2.l,r.l)
; Draws And fills an elliptical sector (a region bounded by the intersection of an ellipse And two radials). It uses the
; current foreground color And fill style. The arguments have the same meaning As in Ellipse. To draw a sector of a circle use PieSlice.
Declare Sector(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
; Selects a user-defined fill pattern which will be used in SetFillStyle routine With UserFill hatch set. The pattern is an 8x8
; raster, corresponding To the 64 bits in (fillpattern). Foreground pattern color is set To (color). Default is White. Background
; pattern color is the background color selected by SetBkColor. Check SetColor To learn more about colors.
; Before returning it calls SetFillStyle routine To put the pattern into effect.
Declare SetFillPattern(Array fillpattern.b(1), color.l) ; FillPatternType
; Sets the filling pattern And color For filled drawings routines. Argument (pattern) can be one of the following constants:
; EmptyFill - background color hatch
; SolidFill - solid hatch
; LineFill - horizontal hatch
; ColFill - vertical hatch
; HatchFill - horizontal And vertical cross-hatch
; SlashFill - 45-degree upward, left-To-right hatch
; BkSlashFill - 45-degree downward, left-To-right hatch
; XHatchFill - 45-degree cross-hatch
; UserFill - user-defined hatch
; NoFill - no hatch
; If (pattern) equals UserFill, the user-defined pattern set by SetFillPattern becomes the active pattern. In this Case, the
; argument (color) is ignored. Parameter (color) is used To fill the shapes. Default is White. Check SetColor To learn about
; color values.
Declare SetFillStyle(pattern.l, color.l)
; Sets the mode in witch flood-fills are performed With FloodFill routine. Argument (floodmode) has the following pre-defined
; values:
; BorderFlood - the fill area is bounded by the color specified in FloodFill filling begins at the specified point and continues
; in all directions Until it reaches the color bounding the area this is the default.
; SurfaceFlood - the fill area is defined by the color that is specified in FloodFill filling begins at the specified point and
; continues in all directions over all adjacent regions containing the specified color this mode is useful for
; filling areas With multicolored boundaries
; See also FloodFill routine.
Declare SetFloodMode(floodmode.l)
; text And font handling exported routines
; Retrieves some information about the current selected font. First argument contains the full registered name of the font
; (ex. "Courier New"). It is the same name used by routine InstallUserFont when the font was installed. Variables (width) And
; (height) contain the maximum dimensions of the characters in the font. If you want To retrive the dimensions of specific
; characters use TextWidth And TextHeight routines. Boolean argument (ttfont) specify If the technology of this font is a
; TrueType one. If so, the text can be rotated on screen using SetTextStyle routine. Otherwise, it cannot be rotated.
Declare GetFontSettings(fontname.s, *width.integer, *height.integer, *ttfont.integer) ; BOOLEAN
; Returns the current font And text settings in argument (textinfo). This contains the font type, direction, magnification,
; horizontal And vertical alignment, As set by SetTextStyle And SetTextJustify routines.
Declare GetTextSettings(*textinfo.TextSettingsType)
; Installs a new font And returns its index into the installed font table. This index can be used With SetTextStyle To enable
; the font For texts. The parameter (fontname) must be a valid family font name registered into the system (ex: " Fixedsys").
; The name IS Case sensitive. If the font cannot be registered, InstallUserFont will Return -1.
; InitGraph installs several fonts using this routine. Default font is set To "Courier New". Other installed fonts are listed in
; section Font constants For text. For more info about fonts see SetTextStyle.
Declare.i InstallUserFont(fontname.s)
; Puts (textstring) on the screen, at the current pointer position, using the current font And text settings. The current
; position is moved To the End of the text. Use SetTextStyle To change font style And SetTextJustify To change text alignment.
; To put text on an absolute location use OutTextXY instead.
Declare OutText(textstring.s, color = -1)
; Puts (textstring) on the screen, at the coordinates (x,y), using the current font And text settings. The current position is
; moved To the End of the text. See OutText For more details.
Declare OutTextXY(x.l,y.l, textstring.s, color = -1)
; It controls the placement of new text, relative To the cursor position. Argument (horiz) controls horizontal placement, And
; can be one of the following pre-defined constants:
; LeftText - text is set left of the pointer
; CenterText - text is set centered horizontally on the pointer
; RightText - text is set To the right of the pointer
; Argument (vert) controls the vertical placement of the text. Its value can be one of the following pre-defined constants:
; TopText - text is placed above the pointer
; BottomText - text is placed under the pointer
; BaselineText - text is placed relative To its base line
; Default text placement is LeftText And TopText.
Declare SetTextJustify(horiz.i,vert.i)
; It controls the style of text To be put on the screen. Pre-defined constants For (font) are:
; CourierNewFont - Courier New font
; MSSansSerifFont - MS Sans Serif font
; TimesNewRomanFont - Times New Roman font
; ArialFont - Arial font
; DefaultFont=CourierNewFont
; Besides, any successfully installed user font can be used insted. See InstallUserFont For details. All these fonts can be Or-ed
; With the following additional styles To change their appearance:
; ItalicFont - italic font
; UnderlineFont - underlined font
; BoldFont - bold font
; Argument (direction) sets the direction of text. It can be any positive value in degrees Or one of the following constants:
; HorizDir = 0
; VertDir = 90
; Between 1 And 5, (charsize) represents the magnification of the characters With a standard font size of 8 pixels. Above 6 it
; represents an absolute font size. Default is set To 16.
; Be aware that some fonts (including pre-defined) do Not support all these styles. See GetFontSettings routine For more details.
; Use SetColor To set text color.
Declare SetTextStyle(font.i,direction.i,charsize.i)
; First argument (nCharExtra) sets the intercharacter spacing in text And the second one (nBreakExtra) sets the amount of space
; reserved For Break character. The other ones are dummy arguments (Not used). This is a major incompatibility With BP graph unit.
; Default values are zero.
; See SetTextStyle For other text styles.
Declare SetUserCharSize(nCharExtra.i,nBreakExtra.i,dummy1.i,dummy2.i)
; Returns the height (in pixels) of the (textstring) in the current font style. This value might be altered by a call To
; SetTextStyle Or SetUserCharSize.
Declare.i TextHeights(textstring.s)
; Returns the width (in pixels) of the (textstring) in the current font style. This value might be altered by a call To
; SetTextStyle Or SetUserCharSize.
Declare.i TextWidths(textstring.s)
Declare THREEDto2DAll(*coords.ThreeDPointType, *pan.ThreeDPointType, *centre.ThreeDPointType, *position.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Declare THREEDto2D(*coords.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Declare DrawSymbol(x.l, y.l, color.l, symbol.l, width.l, height.l)
; caret format: block Or underline
Global CaretBlock.i = 1
; caret blink rate in tenths OF a second
Global BlinkRate.i = 2
Declare DrawCaret(nr.i)
Declare TextSettings()
EndDeclareModule
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Module MINIBGI
EnableExplicit
#NrVideoPages = 4; ;number OF available video pages
#Rad = #PI/180.0
#NrMaxFonts = 15
#MinCharSize = 8
#NrColorNames = 256
Global screenWidth.i,screenHeight.i, hwnd.i
Global Dim interncolor.l(#NrColorNames-1)
Global customWidth.i,customHeight.i
Global windowWidth.i,windowHeight.i
Global windowStyle.l, grHandle.l
Global grTitle.s = "NONAME"
Global maxX.l,maxY.l,origX.l,origY.l, actX.l,actY.l,aspX.l,aspY.l
Global defAspectRatio.i, old_Palette.i
Global grWindow.l,grTemp.l,grMemory.l
Global grPen.l,old_Pen.l
Global grBrush.l,old_Brush.l
Global grFont.l,old_Font.l
Global grPattern.l,old_Bitmap.l
Global Dim grBitmap.i(#NrVideoPages-1)
Global Dim instFont.s(#NrMaxFonts-1)
Global frcolor.l,bkcolor.l,grClip.l
Global lineSettings.LineSettingsType
Global fillSettings.FillSettingsType
Global textSettings.TextSettingsType
Global Dim fillPattern.b(8)
Global viewPort.ViewPortType
Global lastArcCoords.ArcCoordsType
Global viewPortWidth.l,viewPortHeight.l
Global floodMode.l, globalTemp.l
Procedure.b LOBYTE(w.w)
ProcedureReturn w & $0FF
EndProcedure
Procedure.b HIBYTE(w.w)
ProcedureReturn (w >> 8) & $0FF
EndProcedure
Procedure.w LOWORD(l.l)
ProcedureReturn l & $0FFFF
EndProcedure
Procedure.w HIWORD(l.l)
ProcedureReturn (l >> 16) & $0FFFF
EndProcedure
Procedure.i EnumFontFamProc(*lpelf.LOGFONT, *lpntm.NEWTEXTMETRIC, FontType.l, param.i) ;:LPARAM
globalTemp = 1 ; we got here IF at least one font from the family font exists
ProcedureReturn 0
EndProcedure
#NrDefFonts = 4
Procedure InstallDefaultFonts()
Protected Dim DefaultFont.s(#NrDefFonts-1)
Protected i.i
DefaultFont.s(0) = "Courier New"
DefaultFont.s(1) = "MS Sans Serif"
DefaultFont.s(2) = "Times New Roman"
DefaultFont.s(3) = "Arial"
For i = 0 To #NrMaxFonts-1
instFont(i) = ""
Next
For i=0 To #NrDefFonts-1
InstallUserFont(DefaultFont(i))
Next
EndProcedure
Procedure LineProc(x.l,y.l, param.l) ;:LPARAM)
param = param >> globalTemp
If (param & $0001 <> 0)
PutPixel(x,y,frcolor)
EndIf
globalTemp = (globalTemp+1) % 16
EndProcedure
Procedure SetAttrib_BGI()
Protected.i dx_bor,dy_bor,dx,dy,tmp
dx_bor = 2*GetSystemMetrics_(#SM_CXFIXEDFRAME)
dy_bor = 2*GetSystemMetrics_(#SM_CYFIXEDFRAME)+GetSystemMetrics_(#SM_CYCAPTION)
dx = customWidth
dy = customHeight
windowWidth = dx + dx_bor
windowHeight = dy + dy_bor
If (windowWidth <= screenWidth) And (windowHeight <= screenHeight)
windowStyle = #WS_OVERLAPPED | #WS_SYSMENU | #WS_CAPTION | #WS_MINIMIZEBOX
Else
If (dx <= screenWidth) And (dy <= screenHeight)
windowWidth = dx
windowHeight = dy
windowStyle = #WS_POPUP
Else
ProcedureReturn
EndIf
EndIf
EndProcedure
;initialization routines
Procedure CloseGraph()
Protected exitcode.i, i.i
DeleteObject_(grPattern)
For i=0 To #NrVideoPages-1
DeleteObject_(grBitmap(i))
Next
SelectObject_(grWindow,old_Font)
DeleteObject_(grFont)
SelectObject_(grWindow,old_Brush)
DeleteObject_(grBrush)
SelectObject_(grWindow,old_Pen)
DeleteObject_(grPen)
SetViewPort(0,0,maxX,maxY,#ClipOff)
DeleteDC_(grWindow)
EndProcedure
Procedure.i GetDC()
ProcedureReturn grWindow
EndProcedure
Procedure.i InitGraph(windownumber.i, WinX.l, WinY.l, title.s) ;<- main entry point*)
Protected grRect.RECT
Protected.i dx_bor,dy_bor,dx,dy,tmp
Protected *pbmi.BITMAPINFO
Protected pbits.l = #Null ;LPVOID
Protected i.i,nr.i = 0
Protected Dim pattern.b(8) ; FillPatternType
grHandle = WindowID(windownumber)
hwnd = windownumber
GetClientRect_(grHandle, grRect)
maxX = grRect\right-1
maxY = grRect\bottom-1
grWindow = GetDC_(grHandle)
grTemp = CreateCompatibleDC_(#Null)
old_Palette= GetCurrentObject_(grWindow,#OBJ_PAL)
old_Pen = GetCurrentObject_(grWindow,#OBJ_PEN)
old_Brush = GetCurrentObject_(grWindow,#OBJ_BRUSH)
old_Font = GetCurrentObject_(grWindow,#OBJ_FONT)
InstallDefaultFonts()
lineSettings\linestyle = #SolidLn
lineSettings\pattern = 0
lineSettings\thickness = #NormWidth
SetColor(#_Black)
SetBkColor(#_White)
FillMemory(@pattern(0), 8, $FF)
SetFillPattern(pattern(),#_White)
SetFillStyle(#SolidFill,#_White)
SetTextStyle(#DefaultFont,#HorizDir,16)
SetTextJustify(#LeftText,#TopText)
SetUserCharSize(0,0,0,0)
SetViewPort(0,0,maxX,maxY,#ClipOff)
SetWriteMode(#CopyMode | #TRANSPARENT)
defAspectRatio = SetAspectRatio(10000,10000)
floodMode = #BorderFlood
If title <> ""
grTitle = title
EndIf
SetWindowTitle(windownumber, grTitle)
ShowWindow_(grHandle,#SW_SHOWNORMAL)
SetViewPort(0, 0, maxX, maxY, #ClipOff)
ClearViewPort()
; SetWindowSize(WinX,WinY)
SetForegroundWindow_(grHandle)
ProcedureReturn windownumber
EndProcedure
Procedure SetWindowSize(width.l,height.l)
customWidth = width
customHeight = height
EndProcedure
; screen management routines
Procedure ClearDevice()
Protected old_ViewPort.ViewPortType
old_ViewPort = viewPort
SetViewPort(0, 0, maxX, maxY, #ClipOff)
ClearViewPort()
With old_ViewPort
SetViewPort(\x1,\y1,\x2,\y2, \clip)
EndWith
EndProcedure
Procedure ClearViewPort()
Protected old_FillSettings.FillSettingsType
MoveTo(0,0)
old_FillSettings = fillSettings
SetFillStyle(#SolidFill, bkcolor)
Bar(0,0,viewPortWidth,viewPortHeight)
With old_FillSettings
SetFillStyle(\pattern, \color)
EndWith
EndProcedure
Procedure GetAspectRatio(*xasp.integer,*yasp.integer)
*xasp = aspX
*yasp = aspY
EndProcedure
Procedure.i GetMaxX()
ProcedureReturn maxX
EndProcedure
Procedure.i GetMaxY()
ProcedureReturn maxY
EndProcedure
Procedure GetViewSettings(*viewport.ViewPortType)
viewport = viewPort
EndProcedure
Procedure.i GetXX()
ProcedureReturn actX
EndProcedure
Procedure.i GetYY()
ProcedureReturn actY
EndProcedure
Procedure SetAspectRatio(xasp.i,yasp.i)
aspX = xasp
aspY = yasp
defAspectRatio = Bool(Bool(xasp = 10000) And Bool(yasp = 10000))
EndProcedure
Procedure SetViewPort(x1.l,y1.l,x2.l,y2.l, clip.l) ;BOOLEAN
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
viewPort\x1 = x1
viewPort\y1 = y1
viewPort\x2 = x2
viewPort\y2 = y2
viewPort\clip = clip
viewPortWidth = x2-x1
viewPortHeight = y2-y1
origX = x1
origY = y1
MoveTo(0,0)
If grClip <> #Null
SelectClipRgn_(grWindow,#Null)
DeleteObject_(grClip)
grClip = #Null
EndIf
If clip <> 0
grClip = CreateRectRgn_(x1,y1,x2+1,y2+1)
SelectClipRgn_(grWindow,grClip)
EndIf
EndProcedure
Procedure SetWriteMode(writemode.l)
Protected.l fnDrawMode,iBkMode
fnDrawMode = writemode % $10
iBkMode = (writemode / $10) << 4
Select fnDrawMode
Case #CopyMode : fnDrawMode = #R2_COPYPEN
Case #XorMode : fnDrawMode = #R2_XORPEN
Case #OrMode : fnDrawMode = #R2_MERGEPEN
Case #AndMode : fnDrawMode = #R2_MASKPEN
Case #NotMode : fnDrawMode = #R2_NOTCOPYPEN
Case #NotScrMode : fnDrawMode = #R2_NOT
Case #NotXorMode : fnDrawMode = #R2_NOTXORPEN
Case #NotOrMode : fnDrawMode = #R2_NOTMERGEPEN
Case #NotAndMode : fnDrawMode = #R2_NOTMASKPEN
Case #InvColAndMode: fnDrawMode = #R2_MASKNOTPEN
Case #InvColOrMode : fnDrawMode = #R2_MERGENOTPEN
Case #InvScrAndMode: fnDrawMode = #R2_MASKPENNOT
Case #InvScrOrMode : fnDrawMode = #R2_MERGEPENNOT
Case #BlackMode : fnDrawMode = #R2_BLACK
Case #WhiteMode : fnDrawMode = #R2_WHITE
Case #EmptyMode : fnDrawMode = #R2_NOP
Default
ProcedureReturn
EndSelect
Select iBkMode
Case #TRANSPARENT_: iBkMode = #TRANSPARENT
Case #OPAQUE_ : iBkMode = #OPAQUE
Default
ProcedureReturn
EndSelect
SetROP2_(grWindow,fnDrawMode)
SetBkMode_(grWindow,iBkMode)
EndProcedure
; color management routines
Procedure.l GetBkColor()
ProcedureReturn bkcolor
EndProcedure
Procedure.l GetColor()
ProcedureReturn frcolor
EndProcedure
Procedure.l GetMaxColor()
ProcedureReturn $0FFFFFF
EndProcedure
Procedure.l GetPixel(x.l,y.l)
Protected Result.i
Result = GetPixel_(grWindow,x+origX,y+origY)
ProcedureReturn Result
EndProcedure
Procedure GetRGBComponents(color.l, *r.long,*g.long,*b.long, *t.long=#Null)
Protected pe.PALETTEENTRY
*r = Red(color)
*g = Green(color)
*b = Blue(color)
EndProcedure
Procedure SetBkColor(color.l)
bkcolor = color
SetBkColor_(grWindow, color)
EndProcedure
Procedure SetColor(color.l)
frcolor = color
SetTextColor_(grWindow, color)
SetLineStyle(lineSettings\linestyle, lineSettings\pattern, lineSettings\thickness)
EndProcedure
; drawing primitives routines
Procedure Arc(x.l,y.l, start.l,stop.l,radius.l)
Ellipse_(x,y,start,stop,radius)
EndProcedure
Procedure Circles(x.l,y.l, radius.l)
Ellipse_(x,y,0,360,radius)
EndProcedure
Procedure DrawBezier(nrpoints.i, Array *polypoints.PointType(1))
Protected.i size,i
If nrpoints >= 4
PolyBezier_(grWindow, *polypoints(0),nrpoints)
EndIf
EndProcedure
Procedure DrawPoly(nrpoints.i, Array *polypoints.PointType(1))
Protected.i size,i
If nrpoints < 2
ProcedureReturn
EndIf
Polyline_(grWindow,*polypoints(0),nrpoints)
EndProcedure
Procedure Ellipses(x.l, y.l, start.l,stop.l,xradius.l,yradius.l)
Protected.i nXStartArc,nYStartArc,nXEndArc,nYEndArc
lastArcCoords\x = x;
lastArcCoords\y = y
INC(x,origX)
INC(y,origY)
nXStartArc = Round(xradius * Cos(start*#Rad), #PB_Round_Nearest)
nXEndArc = Round(xradius * Cos(stop*#Rad), #PB_Round_Nearest)
nYStartArc = Round(yradius * Sin(start*#Rad), #PB_Round_Nearest)
nYEndArc = Round(yradius * Sin(stop*#Rad), #PB_Round_Nearest)
If defAspectRatio = 0
xradius = Int(10000*xradius) / aspX;
yradius = Int(10000*yradius) / aspY
EndIf
Arc_(grWindow,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1,x+nXStartArc,y-nYStartArc,x+nXEndArc,y-nYEndArc)
With lastArcCoords
\xstart = \x+nXStartArc
\ystart = \y-nYStartArc
\xend = \x+nXEndArc
\yend = \y-nYEndArc
EndWith
EndProcedure
Procedure GetArcCoords(*arccoords.ArcCoordsType)
*arccoords = lastArcCoords
EndProcedure
Procedure GetLineSettings(*lineinfo.LineSettingsType)
*lineinfo = lineSettings
EndProcedure
Procedure Lines(x1.l,y1.l,x2.l,y2.l)
MoveTo(x1,y1)
LineTo(x2,y2)
EndProcedure
Procedure LineRel(dx.l,dy.l)
LineTo(actX+dx,actY+dy)
EndProcedure
Procedure LineTo(x.l,y.l)
Protected.i x0,y0
x0 = x
y0 = y
INC(x, origX)
INC(y, origY)
With lineSettings
If \linestyle <> #UserBitLn
LineTo_(grWindow,x,y)
If \thickness = #NormWidth
PutPixel(x0,y0,frColor)
EndIf
EndIf
MoveTo(x0,y0)
EndWith
EndProcedure
Procedure MoveRel(dx.l,dy.l)
INC(actX, dx)
INC(actY, dy)
MoveTo(actX,actY)
EndProcedure
Procedure MoveTo(x.l,y.l)
Protected d.POINT
actX = x;
actY = y
INC(x, origX)
INC(y, origY)
MoveToEx_(grWindow,x,y,d)
EndProcedure
Procedure PutPixel(x.l,y.l, color.l)
INC(x, origX)
INC(y, origY)
SetPixelV_(grWindow,x,y,color)
EndProcedure
Procedure Rectangle(x1.l,y1.l,x2.l,y2.l)
Protected Dim pt.POINT(5)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
If (x1 <> x2) Or (y1 <> y2)
pt(1)\x = x1: pt(1)\y = y1
pt(2)\x = x2: pt(2)\y = y1
pt(3)\x = x2: pt(3)\y = y2
pt(4)\x = x1: pt(4)\y = y2
pt(5)\x = x1: pt(5)\y = y1
Polyline_(grWindow,@pt(0),5)
Else
PutPixel(x1,y1,frcolor)
EndIf
EndProcedure
Procedure RotEllipse(x.l,y.l,rot.i, xradius.i,yradius.i)
Protected Dim pt.PointType(7)
Protected.d cosrot,sinrot
Protected.i x1,y1,i
xradius = Round(1.3333*xradius, #PB_Round_Nearest)
cosrot = Cos(rot*#Rad): sinrot = Sin(rot*#Rad)
pt(1)\x = 0: pt(1)\y = -Int(yradius)
pt(2)\x = xradius: pt(2)\y = -Int(yradius)
pt(3)\x = xradius: pt(3)\y = (yradius)
pt(4)\x = 0: pt(4)\y = (yradius)
pt(5)\x = -Int(xradius): pt(5)\y = (yradius)
pt(6)\x = -Int(xradius): pt(6)\y = -Int(yradius)
pt(7)\x = 0: pt(7)\y = -Int(yradius)
For i = 1 To 7
x1 = pt(i)\x: y1 = pt(i)\y ; perform rotation
pt(i)\x = x+Round( x1*cosrot+y1*sinrot, #PB_Round_Nearest)
pt(i)\y = y+Round(-x1*sinrot+y1*cosrot, #PB_Round_Nearest)
Next
DrawBezier(7, pt())
EndProcedure
Procedure SetLineStyle(linestyle.i,pattern.l,thickness.i)
Protected lgpn.LOGPEN
Protected old.l ;HGDIOBJ
Protected lstyle.l
DeleteObject_(grPen)
;ReleaseDC_(grHandle, grWindow)
grWindow = GetDC_(grHandle)
Select linestyle
Case #SolidLn : lstyle = #PS_SOLID
Case #DashedLn : lstyle = #PS_DASH
Case #DottedLn : lstyle = #PS_DOT
Case #DashDotLn : lstyle = #PS_DASHDOT
Case #DashDotDotLn : lstyle = #PS_DASHDOTDOT
Case #UserBitLn,#NullLn: lstyle = #PS_NULL
Default
ProcedureReturn
EndSelect
lineSettings\linestyle = linestyle
lineSettings\pattern = pattern
lineSettings\thickness = thickness
lgpn\lopnStyle = lstyle
lgpn\lopnWidth\x = thickness
lgpn\lopnColor = frcolor
grPen = CreatePenIndirect_(lgpn)
SelectObject_(grWindow, grPen)
EndProcedure
;filled drawings routines
Procedure Bar(x1.l,y1.l,x2.l,y2.l)
Protected rc.RECT
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
SetRect_(rc,x1,y1,x2+1,y2+1)
FillRect_(grWindow,rc,grBrush)
EndProcedure
Procedure Bar3D(x1.l,y1.l,x2.l,y2.l, depth.l, top.l) ;:BOOLEAN)
Protected Dim pt.POINT(4)
FillRect(x1,y1,x2,y2);
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
If top <> 0
pt(1)\x = x1: pt(1)\y = y1
pt(2)\x = x1+Int(depth): pt(2)\y = y1-Int(depth)
pt(3)\x = x2+Int(depth): pt(3)\y = y1-Int(depth)
pt(4)\x = x2: pt(4)\y = y1
Polyline_(grWindow,@pt(),4)
EndIf
If depth <> 0
pt(1)\x = x2+Int(depth): pt(1)\y = y1-Int(depth)
pt(2)\x = x2+Int(depth): pt(2)\y = y2-Int(depth)
pt(3)\x = x2: pt(3)\y = y2
Polyline_(grWindow,@pt(),3)
EndIf
EndProcedure
Procedure Chord(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
Protected.i nXRadial1,nYRadial1,nXRadial2,nYRadial2
INC(x, origX)
INC(y, origY)
nXRadial1 = Round(xradius*Cos(start*#Rad), #PB_Round_Nearest): nXRadial2 = Round(xradius*Cos(stop*#Rad), #PB_Round_Nearest)
nYRadial1 = Round(yradius*Sin(start*#Rad), #PB_Round_Nearest): nYRadial2 = Round(yradius*Sin(stop*#Rad), #PB_Round_Nearest)
If defAspectRatio = 0
xradius = 10000*Int(xradius) / aspX: yradius = 10000*Int(yradius) / aspY
EndIf
Chord_(grWindow,x-xradius,y-yradius,x+xradius+1,y+yradius+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2)
EndProcedure
Procedure FillEllipse(x.l,y.l,xradius.i,yradius.i)
INC(x, origX)
INC(y, origY)
If defAspectRatio <> 0
xradius = Int(10000*xradius) / aspX;
yradius = Int(10000*yradius) / aspY
EndIf
Ellipse_(grWindow,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1)
EndProcedure
Procedure FillPoly(nrpoints.i, Array *polypoints.PointType(1))
Protected.i size,i
If nrpoints >= 2
Polygon_(grWindow, *polypoints(), nrpoints)
EndIf
EndProcedure
Procedure FillRect(x1.l,y1.l,x2.l,y2.l)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX+1)
INC(y2, origY+1)
Rectangle_(grWindow,x1,y1,x2,y2)
EndProcedure
Procedure FloodFill(x.l,y.l, color.l)
INC(x, origX)
INC(y, origY)
ExtFloodFill_(grWindow,x,y,color,floodMode)
EndProcedure
Procedure GetFillPattern(Array *fillpatternn.byte(1))
CopyArray(*fillPatternn(), fillpattern())
EndProcedure
Procedure GetFillSettings(*fillinfo.FillSettingsType)
*fillinfo = fillSettings
EndProcedure
Procedure InvertRect(x1.l,y1.l,x2.l,y2.l)
Protected rc.RECT
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
SetRect_(rc,x1,y1,x2+1,y2+1)
InvertRect_(grWindow,rc)
EndProcedure
Procedure PieSlice(x.l,y.l, start.i,stop.i,radius.l)
Sector(x,y,start,stop,radius,radius)
EndProcedure
Procedure RoundRect(x1.l,y1.l,x2.l,y2.l,r.l)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
RoundRect_(grWindow,x1,y1,x2+1,y2+1,r,r)
EndProcedure
Procedure Sector(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
Protected.i nXRadial1,nYRadial1,nXRadial2,nYRadial2
INC(x, origX)
INC(y, origY)
nXRadial1 = Round(xradius*Cos(start*#Rad), #PB_Round_Nearest)
nXRadial2 = Round(xradius*Cos(stop*#Rad), #PB_Round_Nearest)
nYRadial1 = Round(yradius*Sin(start*#Rad), #PB_Round_Nearest)
nYRadial2 = Round(yradius*Sin(stop*#Rad), #PB_Round_Nearest)
If defAspectRatio <> 0
xradius = Int(10000*xradius) / aspX : yradius = Int(10000*yradius) / aspY
EndIf
Pie_(grWindow,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2)
EndProcedure
Procedure SetFillPattern(Array fillpattern.b(1), color.l)
Protected.i i,j
Protected.i col0,col1 ; COLORREF
Protected.b b
CopyArray(fillpattern(), fillPattern())
col1 = color
col0 = bkcolor
If grPattern <> #Null
DeleteObject_(grPattern)
EndIf
grPattern = CreateCompatibleBitmap_(grMemory,8,8)
SelectObject_(grTemp, grPattern)
For i = 0 To 7
b = fillpattern(i+1)
For j = 7 To 0 Step -1
If (b & $01) <> 0
SetPixelV_(grTemp,j,i,col1)
Else
SetPixelV_(grTemp,j,i,col0)
EndIf
b = b >> 1
Next
Next
SelectObject_(grTemp,old_Bitmap)
SetFillStyle(#UserFill, color)
EndProcedure
Procedure SetFillStyle(pattern.l, color.l)
Protected lplb.LOGBRUSH
lplb\lbStyle = #BS_HATCHED
lplb\lbHatch = 0
Select pattern
Case #SolidFill : lplb\lbStyle = #BS_SOLID
Case #EmptyFill : lplb\lbStyle = #BS_SOLID :
color = bkcolor
Case #LineFill : lplb\lbHatch = #HS_HORIZONTAL
Case #ColFill : lplb\lbHatch = #HS_VERTICAL
Case #HatchFill : lplb\lbHatch = #HS_CROSS
Case #SlashFill : lplb\lbHatch = #HS_BDIAGONAL
Case #BkSlashFill: lplb\lbHatch = #HS_FDIAGONAL
Case #XHatchFill : lplb\lbHatch = #HS_DIAGCROSS
Case #UserFill : lplb\lbStyle = #BS_PATTERN :
lplb\lbHatch = grPattern
Case #NoFill : lplb\lbStyle = #BS_NULL
Default
ProcedureReturn
EndSelect
lplb\lbColor = color
fillSettings\pattern = pattern
fillSettings\color = color
DeleteObject_(grBrush)
grBrush = CreateBrushIndirect_(lplb)
SelectObject_(grWindow, grBrush)
EndProcedure
Procedure SetFloodMode(floodmode.l)
Select floodmode
Case #BorderFlood : floodMode = #FLOODFILLBORDER
Case #SurfaceFlood: floodMode = #FLOODFILLSURFACE
EndSelect
EndProcedure
;text And font handling routines
Procedure GetFontSettings(fontname.s, *width.integer, *height.integer, *ttfont.integer) ;:BOOLEAN
Protected *lptm.TEXTMETRIC
Protected len.i
Protected x.s = Space(255), tt.s = ""
len = GetTextFace_(grWindow,255, @x)
tt = Chr(len-1) + Space(255)
GetTextFace_(grWindow,255, @tt)
GetTextMetrics_(grWindow, *lptm)
With *lptm
*width = \tmMaxCharWidth
*height = \tmHeight
*ttfont = Bool((\tmPitchAndFamily & #TMPF_TRUETYPE) <> 0)
EndWith
EndProcedure
Procedure GetTextSettings(*textinfo.TextSettingsType)
*textinfo = textSettings
EndProcedure
Procedure.i InstallUserFont(fontname.s)
Protected.i i, Result=-1
Protected famName.s = ""
famName = fontname
globalTemp = 0
EnumFontFamilies_(grWindow,@famName,@EnumFontFamProc(),0)
If globalTemp = 1
For i = 0 To #NrMaxFonts-1
If instFont(i) = ""
instFont(i) = fontname; ;+0H;*)
Result = i
Break
EndIf
Next
EndIf
ProcedureReturn Result
EndProcedure
Procedure OutText(textstring.s, color = -1)
Protected lpPoint.POINT
Protected len.i
Protected pen.l
len = Len(textstring)
If color = -1
SetTextColor_(grWindow, frcolor)
Else
SetTextColor_(grWindow, color)
EndIf
TextOut_(grWindow,0,0,@textstring,len)
MoveTo(lpPoint\x - origX, lpPoint\y - origY)
If color >= 0 : DeleteObject_(pen) : EndIf
EndProcedure
Procedure OutTextXY(x.l,y.l, textstring.s, color = -1)
MoveTo(x,y)
OutText(textstring, color)
EndProcedure
Procedure SetTextJustify(horiz.i, vert.i)
Protected.i htext,vtext
Select horiz
Case #LeftText : htext = #TA_LEFT
Case #CenterText: htext = #TA_CENTER
Case #RightText : htext = #TA_RIGHT
Default
ProcedureReturn
EndSelect
Select vert
Case #TopText : vtext = #TA_TOP
Case #BottomText : vtext = #TA_BOTTOM
Case #BaselineText: vtext = #TA_BASELINE
Default
ProcedureReturn
EndSelect
textSettings\horiz = horiz
textSettings\vert = vert
SetTextAlign_(grWindow,htext | vtext | #TA_UPDATECP)
SetTextAlign_(grMemory,htext | vtext | #TA_UPDATECP)
EndProcedure
Procedure SetTextStyle(font.i,direction.i,charsize.i)
Protected.b loByte,hiByte
Protected.b nrfont
Protected fontname.s = ""
Protected lplf.LOGFONT
Protected old.i ;HGDIOBJ
loByte = LOBYTE(LOWORD(font))
hiByte = HIBYTE(HIWORD(font))
nrfont = loByte % $10
If (nrfont>=0) And (nrfont <= #NrMaxFonts-1)
fontname = instFont(nrfont)
Else
fontname = ""
EndIf
If fontname <> ""
textSettings\font = font
textSettings\direction = direction
textSettings\charsize = charsize
If charsize <= 5
charsize = charsize * #MinCharSize
EndIf
lplf\lfHeight = charsize
lplf\lfWidth = 0
lplf\lfEscapement = 10 * direction
lplf\lfOrientation = 10 * direction
lplf\lfItalic = #False
lplf\lfWeight = (#FW_BOLD - #FW_NORMAL) * (loByte / $10) + #FW_NORMAL
If (hiByte / $10) > 0
lplf\lfItalic = 1
EndIf
lplf\lfUnderline = 0
If (hiByte / $10) > 0
lplf\lfUnderline = 1
EndIf
lplf\lfStrikeOut = 0
lplf\lfCharSet = #DEFAULT_CHARSET
lplf\lfOutPrecision = #OUT_DEFAULT_PRECIS
lplf\lfClipPrecision = #CLIP_DEFAULT_PRECIS
lplf\lfQuality = #DEFAULT_QUALITY
lplf\lfPitchAndFamily = #DEFAULT_PITCH | #FF_DONTCARE
PokeS(@lplf\lfFaceName[0], fontname)
grFont = CreateFontIndirect_(lplf)
SelectObject_(grWindow, grFont)
EndIf
EndProcedure
Procedure SetUserCharSize(nCharExtra.i,nBreakExtra.i,dummy1.i,dummy2.i)
SetTextCharacterExtra_(grWindow,nCharExtra)
SetTextCharacterExtra_(grMemory,nCharExtra)
SetTextJustification_(grWindow,nBreakExtra,1)
SetTextJustification_(grMemory,nBreakExtra,1)
EndProcedure
Procedure.i TextHeights(textstring.s)
Protected lpSize.SIZE
Protected len.i
len = Len(textstring)
GetTextExtentPoint32_(grMemory,textstring,len,lpSize)
ProcedureReturn lpSize\cy
EndProcedure
Procedure.i TextWidths(textstring.s)
Protected lpSize.SIZE
Protected len.i
len = Len(textstring)
GetTextExtentPoint32_(grMemory,textstring,len,lpSize)
ProcedureReturn lpSize\cx
EndProcedure
Procedure THREEDto2DAll(*coords.ThreeDPointType, *pan.ThreeDPointType, *centre.ThreeDPointType, *position.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Protected new.ThreeDPointType
INC(*coords\x, *position\x)
INC(*coords\y, *position\y)
INC(*coords\z, *position\z)
new\x = *coords\x*Cos(*pan\x) - *coords\z*Sin(*pan\x)
new\z = *coords\x*Sin(*pan\x) + *coords\z*Cos(*pan\x)
new\y = *coords\y*Cos(*pan\y) - new\z*Sin(*pan\y)
*coords\z = new\y*Cos(*pan\y) - new\z*Sin(*pan\y)
*coords\x = new\x*Cos(*pan\z) - new\y*Sin(*pan\z)
*coords\y = new\x*Sin(*pan\z) + new\y*Cos(*pan\z)
If *coords\z > 0.0
*sx = *coords\x / *coords\z * zoom + *centre\x
*sy = *coords\y / *coords\z * zoom + *centre\y
Else
*sx = *coords\x * zoom + *centre\x
*sy = *coords\y * zoom + *centre\y
EndIf
EndProcedure
Procedure THREEDto2D(*coords.ThreeDPointType, zoom.d, *sx.double, *sy.double)
*sx = *coords\x / *coords\z * zoom
*sy = *coords\y / *coords\z * zoom
EndProcedure
Procedure DrawSymbol(x.l, y.l, color.l, symbol.l, width.l, height.l)
Protected currfcol.l = GetColor()
SetColor(color)
Select symbol
Case #SYMBOLRECTANGLE:
lines(x - width/2, y - height/2, x + width/2, y - height/2)
lines(x + width/2, y - height/2, x + width/2, y + height/2)
lines(x + width/2, y + height/2, x - width/2, y + height/2)
lines(x - width/2, y + height/2, x - width/2, y - height/2)
Case #SYMBOLTRIANGLE:
lines(x - width/2, y + height/2, x, y - height/2)
lines(x, y - height/2, x + width/2, y + height/2)
lines(x + width/2, y + height/2, x - width/2, y + height/2)
Case #SYMBOLDIAMOND:
lines(x - width/2, y, x, y - height/2)
lines(x, y - height/2, x + width/2, y)
lines(x + width/2, y, x, y + height/2)
lines(x, y + height/2, x - width/2, y)
Case #SYMBOLCROSS:
lines(x - width/2, y, x + width/2, y)
lines(x, y - height/2, x, y + height/2)
Case #SYMBOLXCROSS:
lines(x - width/2, y + height/2, x + width/2, y - height/2)
lines(x - width/2, y - height/2, x + width/2, y + height/2)
Default
EndSelect
SetColor(currfcol)
EndProcedure
Global old_TextSettings.TextSettingsType
Global.i textX,textY,textW,textH
Procedure DrawCaret(nr.i)
Select nr
Case 0: SetFillStyle(#SolidFill,GetBkColor())
Case 1: SetFillStyle(#SolidFill,GetColor())
EndSelect
If (CaretBlock <> 0) Or (nr = 0)
Bar(textX,textY,textX+textW,textY+textH)
Else
Bar(textX,textY+textH-1,textX+textW,textY+textH)
EndIf
EndProcedure
Procedure TextSettings()
Protected viewport.ViewPortType
With old_TextSettings
SetTextStyle(#DefaultFont | (\font / $10) << 4,0, \charsize) ; keep font format
SetTextJustify(#LeftText, #TopText)
EndWith
textX = GetX()
textY = GetY()
textW = TextWidth("W")
textH = TextHeight("H")
GetViewSettings(viewport)
With viewport
maxX = \x2-\x1
maxY = \y2-\y1
EndWith
EndProcedure
EndModule
Last edited by startup on Sat Sep 19, 2015 3:28 pm, edited 1 time in total.
Re: Help on an error - bgi graphics, function plot modules
XIncludeFile "MINIBGI.pbi"
DeclareModule MINIPLOT
EnableExplicit
#MAXINTEGER = 65535
; sets clipping of plotting on: i.e. only within actual plot region
; delimited by XMin->XMax And YMin->YMax
Declare SetClipOn()
; sets clipping of plotting off: i.e. can plot anywhere on the screen,
; but window is still delimited by XMin->XMax And YMin->YMax
Declare SetClipOff()
; clears a status line at the very top of the screen;
; you have To be in graphics mode For this To work.
Declare Clear_StatusLine()
; writes out a status line "Message" after clearing the status line
; you have To be in graphics mode For this To work.
Declare Write_StatusLine(Message.s)
; defines constants (XAxisScale,YAxisScale,ConstX,ConstY) which are used
; To convert To And from world And window coordinate systems.
Declare Setscale(WXMin.d,WXMax.d,WYMin.d,WYMax.d)
;performs transformation from world coordinates to window (screen) coordinates
Declare World_to_Window(x.d,y.d, *XScreen.integer, *YScreen.integer)
; performs transformation from window (screen) coordinates To world
; coordinates
Declare Window_to_World(XScreen.i,YScreen.i, *x.double, *y.double)
; move graphics cursor To world coordinate X,Y
Declare Move(X.d,Y.d)
; draw line from present position of graphics cursor To world
; coordinate X,Y; use BGI Declare SetLineStyle to change from
; solid To dotted, dashed, etc
Declare Draw(X.d,Y.d)
; move graphics cursor a relative distance (in world coordinates) from
; present position
Declare RelMove(X.d,Y.d)
; draw line from present position of graphics cursor To a new
; position given by the relative distance X,Y (in world coordinates)
; use BGI Declare SetLineStyle To change from solid To dotted,
; dashed, etc
Declare RelDraw(X.d,Y.d)
; Draws tick marks For "axes" And "frame" With minor tick intervals
; every XTick,YTick, And major ticks every XMajor,YMajor minor ticks.
; Tick_Proc checks If x And y axes are running the conventional directions
; (i.e. xmin->max is left To right And ymin->ymax is up) And acts accordingly;
; This routine is only used internally by HiGraf.
Declare Tick_Proc(Xarg.d,Yarg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; draws a frame around box determined by XMin,XMax And YMin,YMax;
; put minor ticks every XTick,YTick interval With major ticks every
; XMajor,YMajor multiples of XTick,YTick; if GridOn = TRUE a grid
; is drawn
Declare Frame(XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; puts STRING Labl at the top of the plot
Declare TopTitle(Labl.s)
; labels x axis With STRING Labl; Label_Axes sets up variable MaxLabHeight
; which is used For XAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabHeight To 0;
Declare XAxisTitle(Labl.s)
; labels y axis With STRING Labl; Label_Axes sets up variable MaxLabLength
; which is used For YAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabLength To 0;
Declare YAxisTitle(Labl.s)
; This Declare draws a label at position X,Y in world coordinates;
; the variables "Font,Direction,Size,XJust,YJust" are just As in the
; BGI description For Turbo Pascal graphics:
; Font,Direction, And Size are set by a BGI proc "SetTextStyle" And
; XJust,YJust are set by a BGI proc "SetTextJustify"
Declare Draw_Label(X.d,Y.d, Strng.s,Font.i,Direction.i,Size.i, XJust.i,YJust.i)
; Draws a pair of axes through XOrg,YOrg With minor tick intervals
; XTick,YTick, And major ticks every XMajor,YMajor minor tick
; intervals; if the flag GridOn = TRUE then a grid is drawn
Declare Axes(XOrg.d,YOrg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; Labels axes at intervals LabelX, LabelY; by convention you may
; want this To be :
; LabelX = XMajor*XTick
; LabelY = YMajor*YTick
; in your program
Declare Label_Axes(LabelX.d,LabelY.d)
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Declare PlotPoint(X.d,Y.d, Symbol.i, SymSize.i, color.i)
; Declare To set up the graph limits.
; The world coordinate limits are XMin, XMax, YMin, And YMax.
; The window limits are WXMin, WXMax, WYMin, WYMax expressed As
; fractions (of 1,i.e. 0.95 etc) of the maximum screen limits.
Declare Setup_Graph(XMin.d,XMax.d,YMin.d,YMax.d, WXMin.d,WXMax.d,WYMin.d,WYMax.d,logx.b,logy.b)
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; error bar on X,Y are sigx and sigy; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Declare PlotData(x.d,sigx.d,y,sigy.d, Symbol.i, SymSize.i, color.i)
EndDeclareModule
Module MINIPLOT
EnableExplicit
UseModule MINIBGI
Global.l Dim Custom_LineStyle(5)
Global.d XWorldMin, XWorldMax,YWorldMin, YWorldMax ; global variables for world limits
Global.i XWindMin, XWindMax, YWindMin, YWindMax ; global variables for window limits
Global.i XViewMax,YViewMax ; viewport limits
Global.d XAxisScale, YAxisScale ; factors for converting
Global.i ConstX, ConstY ; to screen coordinates
Global.b XAxisLog, YAxisLog ; global variables for axis type
Global.i MaxLabLength ; y axis label length in pixels; used To calculate y axis title offset
Global.i MaxLabHeight ; x axis label height in pixels; used To calculate x axis title offset
Global.i MaxColor ; store GetMaxColor value
; sets clipping of plotting on: i.e. only within actual plot region
; delimited by XMin->XMax And YMin->YMax
Procedure SetClipOn()
SetViewPort(XWindMin,YWindMin,XWindMax,YWindMax,#ClipOn)
EndProcedure
; sets clipping of plotting off: i.e. can plot anywhere on the screen,
; but window is still delimited by XMin->XMax And YMin->YMax
Procedure SetClipOff()
SetViewPort(XWindMin,YWindMin,XWindMax,YWindMax,#ClipOff)
EndProcedure
; clears a status line at the very top of the screen;
; you have To be in graphics mode For this To work.
Procedure Clear_StatusLine()
Protected.i Status_Width = 12 ; is status line 12 pixels tall?
SetViewPort(0,0,GetMaxX(),GetMaxY(),#ClipOff)
SetFillStyle(#EmptyFill,GetMaxColor())
Bar(0,0,GetMaxX(),Status_Width)
SetClipOn()
EndProcedure
; writes out a status line "Message" after clearing the status line
; you have To be in graphics mode For this To work.
Procedure Write_StatusLine(Message.s)
Clear_StatusLine()
SetViewPort(0,0,GetMaxX(),GetMaxY(),#ClipOff)
SetTextStyle(#ArialFont,#HorizDir,6)
SetTextJustify(#LeftText,#TopText)
MoveTo(0,0)
OutText(Message)
SetClipOn()
MoveTo(1,2)
EndProcedure
; defines constants (XAxisScale,YAxisScale,ConstX,ConstY) which are used
; To convert To And from world And window coordinate systems.
Procedure Setscale(WXMin.d,WXMax.d,WYMin.d,WYMax.d)
XWindMin = Round(WXMin*GetMaxX()/100.0, #PB_Round_Nearest)
XWindMax = Round(WXMax*GetMaxX()/100.0, #PB_Round_Nearest)
YWindMin = Round(WYMin*GetMaxY()/100.0, #PB_Round_Nearest)
YWindMax = Round(WYMax*GetMaxY()/100.0, #PB_Round_Nearest)
XViewMax = XWindMax-XWindMin
YViewMax = YWindMax-YWindMin
If XAxisLog
XAxisScale = XViewMax /(Log10(XWorldMax)-Log10(XWorldMin))
ConstX = -Round(Log10(XWorldMin)*XAxisScale, #PB_Round_Nearest)
Else
XAxisScale = XViewMax/(XWorldMax-XWorldMin)
ConstX = -Round(XWorldMin*XAxisScale, #PB_Round_Nearest)
EndIf
If YAxisLog
YAxisScale = YViewMax/(Log10(YWorldMin)-Log10(YWorldMax))
ConstY = -Round(Log10(YWorldMax)*YAxisScale, #PB_Round_Nearest)
Else
YAxisScale = YViewMax/(YWorldMin-YWorldMax)
ConstY = -Round(YWorldMax*YAxisScale, #PB_Round_Nearest)
EndIf
EndProcedure
;performs transformation from world coordinates to window (screen) coordinates
Procedure World_to_Window(x.d,y.d, *XScreen.integer, *YScreen.integer)
Protected.d temp
Protected.i isign
If XAxisLog
If (x > 0.0)
x = Log10(x)
Else
x = Log10(XWorldMin)
EndIf
EndIf
If YAxisLog
If (y > 0.0)
y = Log10(y)
Else
y = Log10(YWorldMin)
EndIf
EndIf
temp = x*XAxisScale + ConstX
If temp > 0.0
isign = 1
Else
isign = -1
EndIf
If isign*temp < #MAXINTEGER
*XScreen = Round(temp, #PB_Round_Nearest)
Else
*XScreen = isign*#MAXINTEGER
EndIf
temp = y*YAxisScale + ConstY
If (temp > 0.0)
isign = 1
Else
isign = -1
EndIf
If isign*temp < #MAXINTEGER
*YScreen = Round(temp, #PB_Round_Nearest)
Else
*YScreen = isign*#MAXINTEGER
EndIf
EndProcedure
; performs transformation from window (screen) coordinates To world
; coordinates
Procedure Window_to_World(XScreen.i,YScreen.i, *x.double, *y.double)
*x = (1.0*XScreen-ConstX)/XAxisScale
*y = (1.0*YScreen-ConstY)/YAxisScale
If XAxisLog
*x = Pow(10.0,*x)
EndIf
If YAxisLog
*y = Pow(10.0,*y)
EndIf
EndProcedure
; move graphics cursor To world coordinate X,Y
Procedure Move(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
MoveTo(xs,ys)
EndProcedure
; draw line from present position of graphics cursor To world
; coordinate X,Y; use BGI procedure SetLineStyle to change from
; solid To dotted, dashed, etc
Procedure Draw(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
LineTo(xs,ys)
EndProcedure
; move graphics cursor a relative distance (in world coordinates) from
; present position
Procedure RelMove(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
MoveRel(xs,ys)
EndProcedure
; draw line from present position of graphics cursor To a new
; position given by the relative distance X,Y (in world coordinates)
; use BGI Procedure SetLineStyle To change from solid To dotted,
; dashed, etc
Procedure RelDraw(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
LineRel(xs,ys)
EndProcedure
; Draws tick marks For "axes" And "frame" With minor tick intervals
; every XTick,YTick, And major ticks every XMajor,YMajor minor ticks.
; Tick_Proc checks If x And y axes are running the conventional directions
; (i.e. xmin->max is left To right And ymin->ymax is up) And acts accordingly;
; This routine is only used internally by HiGraf.
Procedure Tick_Proc(Xarg.d,Yarg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
Protected.d XTick_scale = 0.015 ; scale factors for tick lengths
Protected.d YTick_scale = 0.005
Protected.d x, y, decade, tempmin, tempmax
Protected.i ticklen, i
; draw x axis tick marks
ticklen = Round(XTick_scale*GetMaxY(), #PB_Round_Nearest)
If XWorldMin <= XWorldMax ; normal axis direction
tempmin = XWorldMin
tempmax = XWorldMax
Else ; axis is reversed from normal
tempmin = XWorldMax
tempmax = XWorldMin
EndIf
If XAxisLog ; x axis is logarithmic
decade = Pow(10.0,Log(tempmin)) ; get next lower decade
Repeat
Move(decade,Yarg)
LineRel(0,2*ticklen)
LineRel(0,-4*ticklen)
If GridOn
Move(decade,YWorldMin)
Draw(decade,YWorldMax)
EndIf
For i = 2 To 9
x = decade*i
If x<= tempmax
Move(x,Yarg)
LineRel(0,ticklen)
LineRel(0,-2*ticklen)
EndIf
If GridOn
SetLineStyle(#UserBitLn,Custom_LineStyle(3),1) ; fine dotted line
Move(x,YWorldMin)
Draw(x,YWorldMax)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
Next
decade = decade*10.0
Until (decade > tempmax)
ElseIf XTick > 0.0 ; x axis is linear
x = tempmin+XTick
i = 1
Repeat
Move(x,Yarg)
If (i % XMajor) = 0
LineRel(0,2*ticklen)
LineRel(0,-4*ticklen)
Else
LineRel(0,ticklen)
LineRel(0,-2*ticklen)
EndIf
If GridOn
If (i % XMajor) <> 0
SetLineStyle(#UserBitLn,Custom_LineStyle(3),1)
EndIf ; fine dotted line
Move(x,YWorldMin)
Draw(x,YWorldMax)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
INC(x, XTick)
INC(i)
Until (x > tempmax)
EndIf ; ELSE IF (XTick...
; draw y axis tick marks
ticklen = Round(YTick_scale*GetMaxX(), #PB_Round_Nearest)
If YWorldMin <= YWorldMax ; normal axis direction
tempmin = YWorldMin
tempmax = YWorldMax
Else ; axis is reversed from normal
tempmin = YWorldMax
tempmax = YWorldMin
EndIf
If YAxisLog ; y axis is logarithmic
decade = Pow(10.0,Log(tempmin)) ; get next lowest decade
Repeat
Move(Xarg,decade)
LineRel(-2*ticklen,0)
LineRel(4*ticklen,0)
If GridOn
Move(XWorldMin,decade)
Draw(XWorldMax,decade)
EndIf
For i = 2 To 9
y = decade*i
If y <= tempmax
Move(Xarg,y)
LineRel(-ticklen,0)
LineRel(2*ticklen,0)
EndIf
If GridOn
SetLineStyle(#UserBitLn,Custom_LineStyle(3),1) ; fine dotted line
Move(XWorldMin,y)
Draw(XWorldMax,y)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
Next
decade = decade*10.0
Until (decade > tempmax)
ElseIf YTick > 0.0 ; y axis is linear
y = tempmin+YTick
i = 1
Repeat
Move(Xarg,y)
If (i % YMajor) = 0
LineRel(-2*ticklen,0)
LineRel(4*ticklen,0)
Else
LineRel(-ticklen,0)
LineRel(2*ticklen,0)
EndIf
If GridOn
If (i % YMajor) <> 0
SetLineStyle(#UserBitLn,Custom_LineStyle(3),1)
EndIf ; fine dotted line
Move(XWorldMin,y)
Draw(XWorldMax,y)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
INC(y,YTick)
INC(i)
Until y > tempmax
EndIf
EndProcedure
; draws a frame around box determined by XMin,XMax And YMin,YMax;
; put minor ticks every XTick,YTick interval With major ticks every
; XMajor,YMajor multiples of XTick,YTick; if GridOn = TRUE a grid
; is drawn
Procedure Frame(XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
SetClipOff()
; draw frame around world
Move(XWorldMin,YWorldMin)
Draw(XWorldMax,YWorldMin)
Draw(XWorldMax,YWorldMax)
Draw(XWorldMin,YWorldMax)
Draw(XWorldMin,YWorldMin)
SetClipOn()
; add tick marks
Tick_Proc(XWorldMin,YWorldMin,XTick,YTick,XMajor,YMajor,GridOn)
Tick_Proc(XWorldMax,YWorldMax,XTick,YTick,XMajor,YMajor,GridOn)
EndProcedure
Procedure.s Remove_Zeros(Strng.s)
Protected.i i,j,z
Protected.s tmp1,tmp2
Protected.s signs
Strng = Trim(Strng)
i = Len(Strng)
If (Mid(Strng,i-3,i) = "E+0") Or (Mid(Strng,i-3,i) = "E-0")
Strng = Mid(Strng,0,i-4)
i = Len(Strng)
ElseIf (Mid(Strng,i-4,i) = "E+00") Or (Mid(Strng,i-4,i) = "E-00")
Strng = Mid(Strng,0,i-5)
i = Len(Strng)
ElseIf (Mid(Strng,i-5,i) = "E+000") Or (Mid(Strng,i-5,i) = "E-000")
Strng = Mid(Strng,0,i-6)
i = Len(Strng)
ElseIf (Mid(Strng,i-6,i) = "E+0000") Or (Mid(Strng,i-6,i) = "E-0000")
Strng = Mid(Strng,0,i-7)
i = Len(Strng)
EndIf
z = FindString(Strng, "E", 1, #PB_String_NoCase)
If z > 0
tmp1 = Mid(Strng,0,z-1)
If Mid(Strng,z+1,1) = "+"
signs = "E+"
tmp2 = Mid(Strng,z+2,i)
ElseIf Mid(Strng,z+1,1) = "-"
signs = "E-"
tmp2 = Mid(Strng,z+2,i)
Else
tmp2 = Mid(Strng,z+1,i)
EndIf
i = Len(tmp1)
If i > 0
While i > 0
If (Mid(tmp1,i-1,1) = " ") Or (Mid(tmp1,i-1,1) = "0")
;tmp1[i-1] = Chr(0)
tmp1 = Mid(tmp1,0,i)
DEC(i)
Else
Break
EndIf
Wend
EndIf
i = Len(tmp1)
If Mid(tmp1,i-1,1) = "."
tmp1 = Mid(tmp1,0,i-2)
EndIf
; start exponent
i = -1
j = Len(tmp2)
If j > 0
While i < j
If (Mid(tmp2,i+1,1) = " ") Or (Mid(tmp2,i+1,1) = "0")
INC(i)
Else
Break
EndIf
Wend
EndIf
If i >= 0
tmp2 = Mid(tmp2,i+1,j)
EndIf
tmp1 = tmp1 + signs
tmp1 = tmp1 + tmp2
Strng = tmp1;
Else ; regular number such as 20.0000
z = FindString(Strng, ".", 1, #PB_String_NoCase)
If z > 0
i = Len(Strng)
If i > 0
While i > 0
If (Mid(Strng,i-1,1) = " ") Or (Mid(Strng,i-1,1) = "0")
Strng = Mid(Strng,0,i-1)
DEC(i)
Else
Break
EndIf
Wend
EndIf
i = Len(Strng)
If Mid(Strng,i-1,1) = "."
Strng = Mid(Strng,0,i-2)
EndIf
EndIf
EndIf
ProcedureReturn Strng
EndProcedure
; puts STRING Labl at the top of the plot
Procedure TopTitle(Labl.s)
Protected.i scale = 6
Protected.i xw,yw
SetClipOff()
xw = XViewMax / 2
yw = -scale;
SetTextStyle(#CourierNewFont,#HorizDir,16)
SetTextJustify(#CenterText,#BottomText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; labels x axis With STRING Labl; Label_Axes sets up variable MaxLabHeight
; which is used For XAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabHeight To 0;
Procedure XAxisTitle(Labl.s)
Protected.i scale = 10
Protected.i xw,yw
SetClipOff()
xw = XViewMax / 2
yw = YViewMax+MaxLabHeight+scale;
SetTextStyle(#CourierNewFont,#HorizDir,16)
SetTextJustify(#CenterText,#TopText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; labels y axis With STRING Labl; Label_Axes sets up variable MaxLabLength
; which is used For YAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabLength To 0;
Procedure YAxisTitle(Labl.s)
Protected.i scale = 20
Protected.i xw,yw
SetClipOff()
xw = -MaxLabLength-scale ; adjust position for length of y axis number labels
yw = YViewMax / 2
SetTextStyle(#CourierNewFont,#VertDir,16)
SetTextJustify(#RightText,#CenterText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; This Procedure draws a label at position X,Y in world coordinates;
; the variables "Font,Direction,Size,XJust,YJust" are just As in the
; BGI description For Turbo Pascal graphics:
; Font,Direction, And Size are set by a BGI proc "SetTextStyle" And
; XJust,YJust are set by a BGI proc "SetTextJustify"
Procedure Draw_Label(X.d,Y.d, Strng.s,Font.i,Direction.i,Size.i, XJust.i,YJust.i)
Protected.i xw,yw
SetTextJustify(XJust,YJust)
SetTextStyle(Font,Direction,Size)
World_to_Window(X,Y,xw,yw)
OutTextXY(xw,yw,Strng)
EndProcedure
; Draws a pair of axes through XOrg,YOrg With minor tick intervals
; XTick,YTick, And major ticks every XMajor,YMajor minor tick
; intervals; if the flag GridOn = TRUE then a grid is drawn
Procedure Axes(XOrg.d,YOrg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
SetClipOn()
Move(XOrg,YWorldMin)
Draw(XOrg,YWorldMax) ; x axis
Move(XWorldMin,YOrg)
Draw(XWorldMax,YOrg) ; y axis
Tick_Proc(XOrg,YOrg,XTick,YTick,XMajor,YMajor,GridOn) ; draw tick marks
EndProcedure
; Labels axes at intervals LabelX, LabelY; by convention you may
; want this To be :
; LabelX = XMajor*XTick
; LabelY = YMajor*YTick
; in your program
Procedure Label_Axes(LabelX.d,LabelY.d)
Protected.i x_location = 8 ; factors for positioning labels
Protected.i y_location = 8
Protected.i xloc,yloc,templength,tempheight
Protected.d tempminx,tempmaxx,tempminy,tempmaxy
Protected.d x,y
Protected.s labl
SetClipOff()
SetTextStyle(#TimesNewRomanFont,#HorizDir,2)
If XWorldMin <= XWorldMax ; regular axis direction
If XAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMin,xloc,yloc)
Window_to_World(xloc-1,yloc,tempminx,y)
World_to_Window(XWorldMax,YWorldMin,xloc,yloc)
Window_to_World(xloc+1,yloc,tempmaxx,y)
Else ; X axis is linear
tempminx = XWorldMin
tempmaxx = XWorldMax
EndIf
Else ; reversed axis direction
If XAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMax,YWorldMin,xloc,yloc)
Window_to_World(xloc+1,yloc,tempminx,y)
World_to_Window(XWorldMin,YWorldMin,xloc,yloc)
Window_to_World(xloc-1,yloc,tempmaxx,y)
Else ; X axis is linear
tempminx = XWorldMax
tempmaxx = XWorldMin
EndIf
EndIf
If YWorldMin <= YWorldMax ; regular axis direction
If YAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMin,xloc,yloc)
Window_to_World(xloc,yloc+1,x,tempminy)
World_to_Window(XWorldMin,YWorldMax,xloc,yloc)
Window_to_World(xloc,yloc-1,x,tempmaxy)
Else ; Y axis is linear
tempminy = YWorldMin
tempmaxy = YWorldMax
EndIf
Else ; reversed axis direction
If YAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMax,xloc,yloc)
Window_to_World(xloc,yloc-1,x,tempminy)
World_to_Window(XWorldMin,YWorldMin,xloc,yloc)
Window_to_World(xloc,yloc+1,x,tempmaxy)
Else ; Y axis is linear
tempminy = YWorldMax
tempmaxy = YWorldMin
EndIf
EndIf
; label x axis
MaxLabHeight = 0; ; initialize this offset for XAxisTitle
tempheight = 0;
SetTextJustify(#CenterText,#TopText) ; do this just once for linear axis
x = tempminx
If XAxisLog
x = Pow(10.0,Log10(tempminx))
EndIf
While x <= tempmaxx
If XAxisLog
labl = StrD(Log10(x), 3) ; was 6
Else
labl = StrD(x, 3) ; was 5
EndIf
labl = Trim(labl)
labl = Remove_Zeros(labl)
World_to_Window(x,YWorldMin,xloc,yloc)
If XAxisLog ; do an exponentiated label
If (x >= tempminx) And (x <= tempmaxx)
SetTextJustify(#CenterText,#TopText)
INC(yloc,y_location) ; position the "10"
OutTextXY(xloc,yloc,"10")
tempheight = TextHeight("10")
DEC(yloc,(tempheight / 2))
INC(xloc,Int((TextWidth("10") / 2))+3)
tempheight = (tempheight / 2) + Int(TextHeight(labl)) ; pixel height of label
SetTextJustify(#LeftText,#TopText)
OutTextXY(xloc,yloc,labl)
EndIf ; IF ((x >= tempminx...
x = x*10.0
Else ; straight linear label
INC(yloc,y_location)
OutTextXY(xloc,yloc,labl)
tempheight = TextHeight(labl)
INC(x+LabelX)
EndIf ; IF (XAxisLog)...
If tempheight > MaxLabHeight
MaxLabHeight = tempheight
EndIf
Wend ; WHILE
; label y axis
MaxLabLength = 0 ; initialize this offset for YAxisTitle
templength = 0
SetTextJustify(#RightText,#CenterText)
y = tempminy
If YAxisLog
y = Pow(10.0,Log10(tempminy))
EndIf
While y <= tempmaxy
If YAxisLog
labl = StrD(Log10(y), 3) ; was 6
Else
labl = StrD(y, 3) ; was 5
EndIf
labl = Trim(labl)
labl = Remove_Zeros(labl)
World_to_Window(XWorldMin,y,xloc,yloc)
If YAxisLog ; do an exponentiated label
If (y >= tempminy) And (y <= tempmaxy)
SetTextJustify(#RightText,#CenterText)
templength = TextWidth("10")
DEC(xloc,x_location-templength) ; position the "10"
OutTextXY(xloc,yloc,"10")
templength = templength+Int(TextWidth(labl)) ; pixel width of label
DEC(yloc,Int(TextHeight("10") / 2))
INC(xloc,2)
SetTextJustify(#LeftText,#CenterText)
OutTextXY(xloc,yloc,labl)
EndIf ; IF ((y >= tempminy...
y = y*10.0
Else ; straight linear label
DEC(xloc,x_location)
OutTextXY(xloc,yloc,labl)
templength = TextWidth(labl)
INC(y,LabelY)
EndIf
If (templength > MaxLabLength)
MaxLabLength = templength
EndIf
Wend
; restore defaults
SetClipOn()
EndProcedure
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Procedure PlotPoint(X.d,Y.d, Symbol.i, SymSize.i, color.i)
Protected.i del = 1
Protected.i xs,ys,delta,x1,y1
Protected.i curcol
x1 = GetX()
y1 = GetY()
curcol = GetColor()
SetColor(color)
World_to_Window(X,Y,xs,ys)
delta = del*SymSize;
Select Symbol
Case 1 ; plus
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
MoveRel(-delta,-delta)
LineRel(0,2*delta)
Case 2 ; box
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,0)
LineRel(0,2*delta)
LineRel(-2*delta,0)
LineRel(0,-2*delta)
Case 3 ; cross
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,2*delta)
MoveRel(-2*delta,0)
LineRel(2*delta,-2*delta)
Case 4: ; triangle
MoveTo(xs,ys-delta-delta / 3)
LineRel(-delta,2*delta)
LineRel(2*delta,0)
LineRel(-delta,-2*delta)
Case 5 ; inverted triangle
MoveTo(xs,ys+delta+delta / 3)
LineRel(-delta,-2*delta)
LineRel(2*delta,0)
LineRel(-delta,2*delta)
Case 6
Circles(xs,ys,delta) ; open circle
Case 7
FillEllipse(xs,ys,delta,delta) ; closed circle
Case 8
PutPixel(xs,ys,GetMaxColor()) ; unscaled point
Default
EndSelect
MoveTo(x1,y1)
SetColor(curcol)
EndProcedure
; Procedure To set up the graph limits.
; The world coordinate limits are XMin, XMax, YMin, And YMax.
; The window limits are WXMin, WXMax, WYMin, WYMax expressed As
; fractions (of 1,i.e. 0.95 etc) of the maximum screen limits.
Procedure Setup_Graph(XMin.d,XMax.d,YMin.d,YMax.d, WXMin.d,WXMax.d,WYMin.d,WYMax.d,logx.b,logy.b)
If logx = #True
XAxisLog = #True
Else
XAxisLog = #False
EndIf
If logy = #True
YAxisLog = #True
Else
YAxisLog = #False
EndIf
; set global variables for other graphics routines.
XWorldMin = XMin
XWorldMax = XMax
YWorldMin = YMin
YWorldMax = YMax
Setscale(WXMin,WXMax,WYMin,WYMax)
; initialize some global constants just in case Label_Axes is not called
MaxLabLength = 0
MaxLabHeight = 0
; set up defaults for graphics parameters
SetClipOn()
Custom_LineStyle(0) = $0FFFF
Custom_LineStyle(1) = $5555
Custom_LineStyle(2) = $0F0F
Custom_LineStyle(3) = $1111
Custom_LineStyle(4) = $1010
EndProcedure
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; error bar on X,Y are sigx and sigy; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Procedure PlotData(x.d,sigx.d,y,sigy.d, Symbol.i, SymSize.i, color.i)
Protected.i del = 1
Protected.i xs,ys,delta,xx,yy
PlotPoint(x,y,Symbol,SymSize, color)
delta = del*SymSize
xx = GetX()
yy = GetY()
If (sigx > 0.0) ; do x error bar
Move(x+sigx,y)
Draw(x-sigx,y)
World_to_Window(x+sigx,y,xs,ys)
MoveTo(xs,ys-delta)
LineRel(0,2*delta)
World_to_Window(x-sigx,y,xs,ys)
MoveTo(xs,ys-delta)
LineRel(0,2*delta)
EndIf
If (sigy > 0.0) ; do y error bar
Move(x,y+sigy)
Draw(x,y-sigy)
World_to_Window(x,y+sigy,xs,ys)
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
World_to_Window(x,y-sigy,xs,ys)
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
EndIf
MoveTo(xx,yy)
EndProcedure
EndModule
DeclareModule MINIPLOT
EnableExplicit
#MAXINTEGER = 65535
; sets clipping of plotting on: i.e. only within actual plot region
; delimited by XMin->XMax And YMin->YMax
Declare SetClipOn()
; sets clipping of plotting off: i.e. can plot anywhere on the screen,
; but window is still delimited by XMin->XMax And YMin->YMax
Declare SetClipOff()
; clears a status line at the very top of the screen;
; you have To be in graphics mode For this To work.
Declare Clear_StatusLine()
; writes out a status line "Message" after clearing the status line
; you have To be in graphics mode For this To work.
Declare Write_StatusLine(Message.s)
; defines constants (XAxisScale,YAxisScale,ConstX,ConstY) which are used
; To convert To And from world And window coordinate systems.
Declare Setscale(WXMin.d,WXMax.d,WYMin.d,WYMax.d)
;performs transformation from world coordinates to window (screen) coordinates
Declare World_to_Window(x.d,y.d, *XScreen.integer, *YScreen.integer)
; performs transformation from window (screen) coordinates To world
; coordinates
Declare Window_to_World(XScreen.i,YScreen.i, *x.double, *y.double)
; move graphics cursor To world coordinate X,Y
Declare Move(X.d,Y.d)
; draw line from present position of graphics cursor To world
; coordinate X,Y; use BGI Declare SetLineStyle to change from
; solid To dotted, dashed, etc
Declare Draw(X.d,Y.d)
; move graphics cursor a relative distance (in world coordinates) from
; present position
Declare RelMove(X.d,Y.d)
; draw line from present position of graphics cursor To a new
; position given by the relative distance X,Y (in world coordinates)
; use BGI Declare SetLineStyle To change from solid To dotted,
; dashed, etc
Declare RelDraw(X.d,Y.d)
; Draws tick marks For "axes" And "frame" With minor tick intervals
; every XTick,YTick, And major ticks every XMajor,YMajor minor ticks.
; Tick_Proc checks If x And y axes are running the conventional directions
; (i.e. xmin->max is left To right And ymin->ymax is up) And acts accordingly;
; This routine is only used internally by HiGraf.
Declare Tick_Proc(Xarg.d,Yarg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; draws a frame around box determined by XMin,XMax And YMin,YMax;
; put minor ticks every XTick,YTick interval With major ticks every
; XMajor,YMajor multiples of XTick,YTick; if GridOn = TRUE a grid
; is drawn
Declare Frame(XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; puts STRING Labl at the top of the plot
Declare TopTitle(Labl.s)
; labels x axis With STRING Labl; Label_Axes sets up variable MaxLabHeight
; which is used For XAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabHeight To 0;
Declare XAxisTitle(Labl.s)
; labels y axis With STRING Labl; Label_Axes sets up variable MaxLabLength
; which is used For YAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabLength To 0;
Declare YAxisTitle(Labl.s)
; This Declare draws a label at position X,Y in world coordinates;
; the variables "Font,Direction,Size,XJust,YJust" are just As in the
; BGI description For Turbo Pascal graphics:
; Font,Direction, And Size are set by a BGI proc "SetTextStyle" And
; XJust,YJust are set by a BGI proc "SetTextJustify"
Declare Draw_Label(X.d,Y.d, Strng.s,Font.i,Direction.i,Size.i, XJust.i,YJust.i)
; Draws a pair of axes through XOrg,YOrg With minor tick intervals
; XTick,YTick, And major ticks every XMajor,YMajor minor tick
; intervals; if the flag GridOn = TRUE then a grid is drawn
Declare Axes(XOrg.d,YOrg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; Labels axes at intervals LabelX, LabelY; by convention you may
; want this To be :
; LabelX = XMajor*XTick
; LabelY = YMajor*YTick
; in your program
Declare Label_Axes(LabelX.d,LabelY.d)
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Declare PlotPoint(X.d,Y.d, Symbol.i, SymSize.i, color.i)
; Declare To set up the graph limits.
; The world coordinate limits are XMin, XMax, YMin, And YMax.
; The window limits are WXMin, WXMax, WYMin, WYMax expressed As
; fractions (of 1,i.e. 0.95 etc) of the maximum screen limits.
Declare Setup_Graph(XMin.d,XMax.d,YMin.d,YMax.d, WXMin.d,WXMax.d,WYMin.d,WYMax.d,logx.b,logy.b)
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; error bar on X,Y are sigx and sigy; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Declare PlotData(x.d,sigx.d,y,sigy.d, Symbol.i, SymSize.i, color.i)
EndDeclareModule
Module MINIPLOT
EnableExplicit
UseModule MINIBGI
Global.l Dim Custom_LineStyle(5)
Global.d XWorldMin, XWorldMax,YWorldMin, YWorldMax ; global variables for world limits
Global.i XWindMin, XWindMax, YWindMin, YWindMax ; global variables for window limits
Global.i XViewMax,YViewMax ; viewport limits
Global.d XAxisScale, YAxisScale ; factors for converting
Global.i ConstX, ConstY ; to screen coordinates
Global.b XAxisLog, YAxisLog ; global variables for axis type
Global.i MaxLabLength ; y axis label length in pixels; used To calculate y axis title offset
Global.i MaxLabHeight ; x axis label height in pixels; used To calculate x axis title offset
Global.i MaxColor ; store GetMaxColor value
; sets clipping of plotting on: i.e. only within actual plot region
; delimited by XMin->XMax And YMin->YMax
Procedure SetClipOn()
SetViewPort(XWindMin,YWindMin,XWindMax,YWindMax,#ClipOn)
EndProcedure
; sets clipping of plotting off: i.e. can plot anywhere on the screen,
; but window is still delimited by XMin->XMax And YMin->YMax
Procedure SetClipOff()
SetViewPort(XWindMin,YWindMin,XWindMax,YWindMax,#ClipOff)
EndProcedure
; clears a status line at the very top of the screen;
; you have To be in graphics mode For this To work.
Procedure Clear_StatusLine()
Protected.i Status_Width = 12 ; is status line 12 pixels tall?
SetViewPort(0,0,GetMaxX(),GetMaxY(),#ClipOff)
SetFillStyle(#EmptyFill,GetMaxColor())
Bar(0,0,GetMaxX(),Status_Width)
SetClipOn()
EndProcedure
; writes out a status line "Message" after clearing the status line
; you have To be in graphics mode For this To work.
Procedure Write_StatusLine(Message.s)
Clear_StatusLine()
SetViewPort(0,0,GetMaxX(),GetMaxY(),#ClipOff)
SetTextStyle(#ArialFont,#HorizDir,6)
SetTextJustify(#LeftText,#TopText)
MoveTo(0,0)
OutText(Message)
SetClipOn()
MoveTo(1,2)
EndProcedure
; defines constants (XAxisScale,YAxisScale,ConstX,ConstY) which are used
; To convert To And from world And window coordinate systems.
Procedure Setscale(WXMin.d,WXMax.d,WYMin.d,WYMax.d)
XWindMin = Round(WXMin*GetMaxX()/100.0, #PB_Round_Nearest)
XWindMax = Round(WXMax*GetMaxX()/100.0, #PB_Round_Nearest)
YWindMin = Round(WYMin*GetMaxY()/100.0, #PB_Round_Nearest)
YWindMax = Round(WYMax*GetMaxY()/100.0, #PB_Round_Nearest)
XViewMax = XWindMax-XWindMin
YViewMax = YWindMax-YWindMin
If XAxisLog
XAxisScale = XViewMax /(Log10(XWorldMax)-Log10(XWorldMin))
ConstX = -Round(Log10(XWorldMin)*XAxisScale, #PB_Round_Nearest)
Else
XAxisScale = XViewMax/(XWorldMax-XWorldMin)
ConstX = -Round(XWorldMin*XAxisScale, #PB_Round_Nearest)
EndIf
If YAxisLog
YAxisScale = YViewMax/(Log10(YWorldMin)-Log10(YWorldMax))
ConstY = -Round(Log10(YWorldMax)*YAxisScale, #PB_Round_Nearest)
Else
YAxisScale = YViewMax/(YWorldMin-YWorldMax)
ConstY = -Round(YWorldMax*YAxisScale, #PB_Round_Nearest)
EndIf
EndProcedure
;performs transformation from world coordinates to window (screen) coordinates
Procedure World_to_Window(x.d,y.d, *XScreen.integer, *YScreen.integer)
Protected.d temp
Protected.i isign
If XAxisLog
If (x > 0.0)
x = Log10(x)
Else
x = Log10(XWorldMin)
EndIf
EndIf
If YAxisLog
If (y > 0.0)
y = Log10(y)
Else
y = Log10(YWorldMin)
EndIf
EndIf
temp = x*XAxisScale + ConstX
If temp > 0.0
isign = 1
Else
isign = -1
EndIf
If isign*temp < #MAXINTEGER
*XScreen = Round(temp, #PB_Round_Nearest)
Else
*XScreen = isign*#MAXINTEGER
EndIf
temp = y*YAxisScale + ConstY
If (temp > 0.0)
isign = 1
Else
isign = -1
EndIf
If isign*temp < #MAXINTEGER
*YScreen = Round(temp, #PB_Round_Nearest)
Else
*YScreen = isign*#MAXINTEGER
EndIf
EndProcedure
; performs transformation from window (screen) coordinates To world
; coordinates
Procedure Window_to_World(XScreen.i,YScreen.i, *x.double, *y.double)
*x = (1.0*XScreen-ConstX)/XAxisScale
*y = (1.0*YScreen-ConstY)/YAxisScale
If XAxisLog
*x = Pow(10.0,*x)
EndIf
If YAxisLog
*y = Pow(10.0,*y)
EndIf
EndProcedure
; move graphics cursor To world coordinate X,Y
Procedure Move(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
MoveTo(xs,ys)
EndProcedure
; draw line from present position of graphics cursor To world
; coordinate X,Y; use BGI procedure SetLineStyle to change from
; solid To dotted, dashed, etc
Procedure Draw(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
LineTo(xs,ys)
EndProcedure
; move graphics cursor a relative distance (in world coordinates) from
; present position
Procedure RelMove(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
MoveRel(xs,ys)
EndProcedure
; draw line from present position of graphics cursor To a new
; position given by the relative distance X,Y (in world coordinates)
; use BGI Procedure SetLineStyle To change from solid To dotted,
; dashed, etc
Procedure RelDraw(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
LineRel(xs,ys)
EndProcedure
; Draws tick marks For "axes" And "frame" With minor tick intervals
; every XTick,YTick, And major ticks every XMajor,YMajor minor ticks.
; Tick_Proc checks If x And y axes are running the conventional directions
; (i.e. xmin->max is left To right And ymin->ymax is up) And acts accordingly;
; This routine is only used internally by HiGraf.
Procedure Tick_Proc(Xarg.d,Yarg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
Protected.d XTick_scale = 0.015 ; scale factors for tick lengths
Protected.d YTick_scale = 0.005
Protected.d x, y, decade, tempmin, tempmax
Protected.i ticklen, i
; draw x axis tick marks
ticklen = Round(XTick_scale*GetMaxY(), #PB_Round_Nearest)
If XWorldMin <= XWorldMax ; normal axis direction
tempmin = XWorldMin
tempmax = XWorldMax
Else ; axis is reversed from normal
tempmin = XWorldMax
tempmax = XWorldMin
EndIf
If XAxisLog ; x axis is logarithmic
decade = Pow(10.0,Log(tempmin)) ; get next lower decade
Repeat
Move(decade,Yarg)
LineRel(0,2*ticklen)
LineRel(0,-4*ticklen)
If GridOn
Move(decade,YWorldMin)
Draw(decade,YWorldMax)
EndIf
For i = 2 To 9
x = decade*i
If x<= tempmax
Move(x,Yarg)
LineRel(0,ticklen)
LineRel(0,-2*ticklen)
EndIf
If GridOn
SetLineStyle(#UserBitLn,Custom_LineStyle(3),1) ; fine dotted line
Move(x,YWorldMin)
Draw(x,YWorldMax)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
Next
decade = decade*10.0
Until (decade > tempmax)
ElseIf XTick > 0.0 ; x axis is linear
x = tempmin+XTick
i = 1
Repeat
Move(x,Yarg)
If (i % XMajor) = 0
LineRel(0,2*ticklen)
LineRel(0,-4*ticklen)
Else
LineRel(0,ticklen)
LineRel(0,-2*ticklen)
EndIf
If GridOn
If (i % XMajor) <> 0
SetLineStyle(#UserBitLn,Custom_LineStyle(3),1)
EndIf ; fine dotted line
Move(x,YWorldMin)
Draw(x,YWorldMax)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
INC(x, XTick)
INC(i)
Until (x > tempmax)
EndIf ; ELSE IF (XTick...
; draw y axis tick marks
ticklen = Round(YTick_scale*GetMaxX(), #PB_Round_Nearest)
If YWorldMin <= YWorldMax ; normal axis direction
tempmin = YWorldMin
tempmax = YWorldMax
Else ; axis is reversed from normal
tempmin = YWorldMax
tempmax = YWorldMin
EndIf
If YAxisLog ; y axis is logarithmic
decade = Pow(10.0,Log(tempmin)) ; get next lowest decade
Repeat
Move(Xarg,decade)
LineRel(-2*ticklen,0)
LineRel(4*ticklen,0)
If GridOn
Move(XWorldMin,decade)
Draw(XWorldMax,decade)
EndIf
For i = 2 To 9
y = decade*i
If y <= tempmax
Move(Xarg,y)
LineRel(-ticklen,0)
LineRel(2*ticklen,0)
EndIf
If GridOn
SetLineStyle(#UserBitLn,Custom_LineStyle(3),1) ; fine dotted line
Move(XWorldMin,y)
Draw(XWorldMax,y)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
Next
decade = decade*10.0
Until (decade > tempmax)
ElseIf YTick > 0.0 ; y axis is linear
y = tempmin+YTick
i = 1
Repeat
Move(Xarg,y)
If (i % YMajor) = 0
LineRel(-2*ticklen,0)
LineRel(4*ticklen,0)
Else
LineRel(-ticklen,0)
LineRel(2*ticklen,0)
EndIf
If GridOn
If (i % YMajor) <> 0
SetLineStyle(#UserBitLn,Custom_LineStyle(3),1)
EndIf ; fine dotted line
Move(XWorldMin,y)
Draw(XWorldMax,y)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
INC(y,YTick)
INC(i)
Until y > tempmax
EndIf
EndProcedure
; draws a frame around box determined by XMin,XMax And YMin,YMax;
; put minor ticks every XTick,YTick interval With major ticks every
; XMajor,YMajor multiples of XTick,YTick; if GridOn = TRUE a grid
; is drawn
Procedure Frame(XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
SetClipOff()
; draw frame around world
Move(XWorldMin,YWorldMin)
Draw(XWorldMax,YWorldMin)
Draw(XWorldMax,YWorldMax)
Draw(XWorldMin,YWorldMax)
Draw(XWorldMin,YWorldMin)
SetClipOn()
; add tick marks
Tick_Proc(XWorldMin,YWorldMin,XTick,YTick,XMajor,YMajor,GridOn)
Tick_Proc(XWorldMax,YWorldMax,XTick,YTick,XMajor,YMajor,GridOn)
EndProcedure
Procedure.s Remove_Zeros(Strng.s)
Protected.i i,j,z
Protected.s tmp1,tmp2
Protected.s signs
Strng = Trim(Strng)
i = Len(Strng)
If (Mid(Strng,i-3,i) = "E+0") Or (Mid(Strng,i-3,i) = "E-0")
Strng = Mid(Strng,0,i-4)
i = Len(Strng)
ElseIf (Mid(Strng,i-4,i) = "E+00") Or (Mid(Strng,i-4,i) = "E-00")
Strng = Mid(Strng,0,i-5)
i = Len(Strng)
ElseIf (Mid(Strng,i-5,i) = "E+000") Or (Mid(Strng,i-5,i) = "E-000")
Strng = Mid(Strng,0,i-6)
i = Len(Strng)
ElseIf (Mid(Strng,i-6,i) = "E+0000") Or (Mid(Strng,i-6,i) = "E-0000")
Strng = Mid(Strng,0,i-7)
i = Len(Strng)
EndIf
z = FindString(Strng, "E", 1, #PB_String_NoCase)
If z > 0
tmp1 = Mid(Strng,0,z-1)
If Mid(Strng,z+1,1) = "+"
signs = "E+"
tmp2 = Mid(Strng,z+2,i)
ElseIf Mid(Strng,z+1,1) = "-"
signs = "E-"
tmp2 = Mid(Strng,z+2,i)
Else
tmp2 = Mid(Strng,z+1,i)
EndIf
i = Len(tmp1)
If i > 0
While i > 0
If (Mid(tmp1,i-1,1) = " ") Or (Mid(tmp1,i-1,1) = "0")
;tmp1[i-1] = Chr(0)
tmp1 = Mid(tmp1,0,i)
DEC(i)
Else
Break
EndIf
Wend
EndIf
i = Len(tmp1)
If Mid(tmp1,i-1,1) = "."
tmp1 = Mid(tmp1,0,i-2)
EndIf
; start exponent
i = -1
j = Len(tmp2)
If j > 0
While i < j
If (Mid(tmp2,i+1,1) = " ") Or (Mid(tmp2,i+1,1) = "0")
INC(i)
Else
Break
EndIf
Wend
EndIf
If i >= 0
tmp2 = Mid(tmp2,i+1,j)
EndIf
tmp1 = tmp1 + signs
tmp1 = tmp1 + tmp2
Strng = tmp1;
Else ; regular number such as 20.0000
z = FindString(Strng, ".", 1, #PB_String_NoCase)
If z > 0
i = Len(Strng)
If i > 0
While i > 0
If (Mid(Strng,i-1,1) = " ") Or (Mid(Strng,i-1,1) = "0")
Strng = Mid(Strng,0,i-1)
DEC(i)
Else
Break
EndIf
Wend
EndIf
i = Len(Strng)
If Mid(Strng,i-1,1) = "."
Strng = Mid(Strng,0,i-2)
EndIf
EndIf
EndIf
ProcedureReturn Strng
EndProcedure
; puts STRING Labl at the top of the plot
Procedure TopTitle(Labl.s)
Protected.i scale = 6
Protected.i xw,yw
SetClipOff()
xw = XViewMax / 2
yw = -scale;
SetTextStyle(#CourierNewFont,#HorizDir,16)
SetTextJustify(#CenterText,#BottomText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; labels x axis With STRING Labl; Label_Axes sets up variable MaxLabHeight
; which is used For XAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabHeight To 0;
Procedure XAxisTitle(Labl.s)
Protected.i scale = 10
Protected.i xw,yw
SetClipOff()
xw = XViewMax / 2
yw = YViewMax+MaxLabHeight+scale;
SetTextStyle(#CourierNewFont,#HorizDir,16)
SetTextJustify(#CenterText,#TopText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; labels y axis With STRING Labl; Label_Axes sets up variable MaxLabLength
; which is used For YAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabLength To 0;
Procedure YAxisTitle(Labl.s)
Protected.i scale = 20
Protected.i xw,yw
SetClipOff()
xw = -MaxLabLength-scale ; adjust position for length of y axis number labels
yw = YViewMax / 2
SetTextStyle(#CourierNewFont,#VertDir,16)
SetTextJustify(#RightText,#CenterText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; This Procedure draws a label at position X,Y in world coordinates;
; the variables "Font,Direction,Size,XJust,YJust" are just As in the
; BGI description For Turbo Pascal graphics:
; Font,Direction, And Size are set by a BGI proc "SetTextStyle" And
; XJust,YJust are set by a BGI proc "SetTextJustify"
Procedure Draw_Label(X.d,Y.d, Strng.s,Font.i,Direction.i,Size.i, XJust.i,YJust.i)
Protected.i xw,yw
SetTextJustify(XJust,YJust)
SetTextStyle(Font,Direction,Size)
World_to_Window(X,Y,xw,yw)
OutTextXY(xw,yw,Strng)
EndProcedure
; Draws a pair of axes through XOrg,YOrg With minor tick intervals
; XTick,YTick, And major ticks every XMajor,YMajor minor tick
; intervals; if the flag GridOn = TRUE then a grid is drawn
Procedure Axes(XOrg.d,YOrg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
SetClipOn()
Move(XOrg,YWorldMin)
Draw(XOrg,YWorldMax) ; x axis
Move(XWorldMin,YOrg)
Draw(XWorldMax,YOrg) ; y axis
Tick_Proc(XOrg,YOrg,XTick,YTick,XMajor,YMajor,GridOn) ; draw tick marks
EndProcedure
; Labels axes at intervals LabelX, LabelY; by convention you may
; want this To be :
; LabelX = XMajor*XTick
; LabelY = YMajor*YTick
; in your program
Procedure Label_Axes(LabelX.d,LabelY.d)
Protected.i x_location = 8 ; factors for positioning labels
Protected.i y_location = 8
Protected.i xloc,yloc,templength,tempheight
Protected.d tempminx,tempmaxx,tempminy,tempmaxy
Protected.d x,y
Protected.s labl
SetClipOff()
SetTextStyle(#TimesNewRomanFont,#HorizDir,2)
If XWorldMin <= XWorldMax ; regular axis direction
If XAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMin,xloc,yloc)
Window_to_World(xloc-1,yloc,tempminx,y)
World_to_Window(XWorldMax,YWorldMin,xloc,yloc)
Window_to_World(xloc+1,yloc,tempmaxx,y)
Else ; X axis is linear
tempminx = XWorldMin
tempmaxx = XWorldMax
EndIf
Else ; reversed axis direction
If XAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMax,YWorldMin,xloc,yloc)
Window_to_World(xloc+1,yloc,tempminx,y)
World_to_Window(XWorldMin,YWorldMin,xloc,yloc)
Window_to_World(xloc-1,yloc,tempmaxx,y)
Else ; X axis is linear
tempminx = XWorldMax
tempmaxx = XWorldMin
EndIf
EndIf
If YWorldMin <= YWorldMax ; regular axis direction
If YAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMin,xloc,yloc)
Window_to_World(xloc,yloc+1,x,tempminy)
World_to_Window(XWorldMin,YWorldMax,xloc,yloc)
Window_to_World(xloc,yloc-1,x,tempmaxy)
Else ; Y axis is linear
tempminy = YWorldMin
tempmaxy = YWorldMax
EndIf
Else ; reversed axis direction
If YAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMax,xloc,yloc)
Window_to_World(xloc,yloc-1,x,tempminy)
World_to_Window(XWorldMin,YWorldMin,xloc,yloc)
Window_to_World(xloc,yloc+1,x,tempmaxy)
Else ; Y axis is linear
tempminy = YWorldMax
tempmaxy = YWorldMin
EndIf
EndIf
; label x axis
MaxLabHeight = 0; ; initialize this offset for XAxisTitle
tempheight = 0;
SetTextJustify(#CenterText,#TopText) ; do this just once for linear axis
x = tempminx
If XAxisLog
x = Pow(10.0,Log10(tempminx))
EndIf
While x <= tempmaxx
If XAxisLog
labl = StrD(Log10(x), 3) ; was 6
Else
labl = StrD(x, 3) ; was 5
EndIf
labl = Trim(labl)
labl = Remove_Zeros(labl)
World_to_Window(x,YWorldMin,xloc,yloc)
If XAxisLog ; do an exponentiated label
If (x >= tempminx) And (x <= tempmaxx)
SetTextJustify(#CenterText,#TopText)
INC(yloc,y_location) ; position the "10"
OutTextXY(xloc,yloc,"10")
tempheight = TextHeight("10")
DEC(yloc,(tempheight / 2))
INC(xloc,Int((TextWidth("10") / 2))+3)
tempheight = (tempheight / 2) + Int(TextHeight(labl)) ; pixel height of label
SetTextJustify(#LeftText,#TopText)
OutTextXY(xloc,yloc,labl)
EndIf ; IF ((x >= tempminx...
x = x*10.0
Else ; straight linear label
INC(yloc,y_location)
OutTextXY(xloc,yloc,labl)
tempheight = TextHeight(labl)
INC(x+LabelX)
EndIf ; IF (XAxisLog)...
If tempheight > MaxLabHeight
MaxLabHeight = tempheight
EndIf
Wend ; WHILE
; label y axis
MaxLabLength = 0 ; initialize this offset for YAxisTitle
templength = 0
SetTextJustify(#RightText,#CenterText)
y = tempminy
If YAxisLog
y = Pow(10.0,Log10(tempminy))
EndIf
While y <= tempmaxy
If YAxisLog
labl = StrD(Log10(y), 3) ; was 6
Else
labl = StrD(y, 3) ; was 5
EndIf
labl = Trim(labl)
labl = Remove_Zeros(labl)
World_to_Window(XWorldMin,y,xloc,yloc)
If YAxisLog ; do an exponentiated label
If (y >= tempminy) And (y <= tempmaxy)
SetTextJustify(#RightText,#CenterText)
templength = TextWidth("10")
DEC(xloc,x_location-templength) ; position the "10"
OutTextXY(xloc,yloc,"10")
templength = templength+Int(TextWidth(labl)) ; pixel width of label
DEC(yloc,Int(TextHeight("10") / 2))
INC(xloc,2)
SetTextJustify(#LeftText,#CenterText)
OutTextXY(xloc,yloc,labl)
EndIf ; IF ((y >= tempminy...
y = y*10.0
Else ; straight linear label
DEC(xloc,x_location)
OutTextXY(xloc,yloc,labl)
templength = TextWidth(labl)
INC(y,LabelY)
EndIf
If (templength > MaxLabLength)
MaxLabLength = templength
EndIf
Wend
; restore defaults
SetClipOn()
EndProcedure
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Procedure PlotPoint(X.d,Y.d, Symbol.i, SymSize.i, color.i)
Protected.i del = 1
Protected.i xs,ys,delta,x1,y1
Protected.i curcol
x1 = GetX()
y1 = GetY()
curcol = GetColor()
SetColor(color)
World_to_Window(X,Y,xs,ys)
delta = del*SymSize;
Select Symbol
Case 1 ; plus
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
MoveRel(-delta,-delta)
LineRel(0,2*delta)
Case 2 ; box
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,0)
LineRel(0,2*delta)
LineRel(-2*delta,0)
LineRel(0,-2*delta)
Case 3 ; cross
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,2*delta)
MoveRel(-2*delta,0)
LineRel(2*delta,-2*delta)
Case 4: ; triangle
MoveTo(xs,ys-delta-delta / 3)
LineRel(-delta,2*delta)
LineRel(2*delta,0)
LineRel(-delta,-2*delta)
Case 5 ; inverted triangle
MoveTo(xs,ys+delta+delta / 3)
LineRel(-delta,-2*delta)
LineRel(2*delta,0)
LineRel(-delta,2*delta)
Case 6
Circles(xs,ys,delta) ; open circle
Case 7
FillEllipse(xs,ys,delta,delta) ; closed circle
Case 8
PutPixel(xs,ys,GetMaxColor()) ; unscaled point
Default
EndSelect
MoveTo(x1,y1)
SetColor(curcol)
EndProcedure
; Procedure To set up the graph limits.
; The world coordinate limits are XMin, XMax, YMin, And YMax.
; The window limits are WXMin, WXMax, WYMin, WYMax expressed As
; fractions (of 1,i.e. 0.95 etc) of the maximum screen limits.
Procedure Setup_Graph(XMin.d,XMax.d,YMin.d,YMax.d, WXMin.d,WXMax.d,WYMin.d,WYMax.d,logx.b,logy.b)
If logx = #True
XAxisLog = #True
Else
XAxisLog = #False
EndIf
If logy = #True
YAxisLog = #True
Else
YAxisLog = #False
EndIf
; set global variables for other graphics routines.
XWorldMin = XMin
XWorldMax = XMax
YWorldMin = YMin
YWorldMax = YMax
Setscale(WXMin,WXMax,WYMin,WYMax)
; initialize some global constants just in case Label_Axes is not called
MaxLabLength = 0
MaxLabHeight = 0
; set up defaults for graphics parameters
SetClipOn()
Custom_LineStyle(0) = $0FFFF
Custom_LineStyle(1) = $5555
Custom_LineStyle(2) = $0F0F
Custom_LineStyle(3) = $1111
Custom_LineStyle(4) = $1010
EndProcedure
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; error bar on X,Y are sigx and sigy; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Procedure PlotData(x.d,sigx.d,y,sigy.d, Symbol.i, SymSize.i, color.i)
Protected.i del = 1
Protected.i xs,ys,delta,xx,yy
PlotPoint(x,y,Symbol,SymSize, color)
delta = del*SymSize
xx = GetX()
yy = GetY()
If (sigx > 0.0) ; do x error bar
Move(x+sigx,y)
Draw(x-sigx,y)
World_to_Window(x+sigx,y,xs,ys)
MoveTo(xs,ys-delta)
LineRel(0,2*delta)
World_to_Window(x-sigx,y,xs,ys)
MoveTo(xs,ys-delta)
LineRel(0,2*delta)
EndIf
If (sigy > 0.0) ; do y error bar
Move(x,y+sigy)
Draw(x,y-sigy)
World_to_Window(x,y+sigy,xs,ys)
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
World_to_Window(x,y-sigy,xs,ys)
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
EndIf
MoveTo(xx,yy)
EndProcedure
EndModule
Re: Help on an error - bgi graphics, function plot modules
Code: Select all
XIncludeFile "MINIPLOT.pbi"
XIncludeFile "MINIBGI.pbi"
UseModule MINIPLOT
UseModule MINIBGI
EnableExplicit
Procedure.d sinc(x.d)
If x=0.0
ProcedureReturn 1.0
Else
ProcedureReturn Sin(x/x*x)
EndIf
EndProcedure
Global x.d,xwin=800, ywin=800
Global Event.i, Quit.i, wnum.i,MaxX.i,MaxY.i,MaxRadius.i
wnum = OpenWindow(#PB_Any, 100, 200, xwin, ywin, "PureBasic Window", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget)
If wnum
InitGraph(wnum, xwin, ywin, "tester")
Setup_Graph(-5.0, 20.0, -0.1, 2.5, 10.0, 65.0,10.0, 65.0, #False, #False)
SetColor(#Black)
Frame(1.0,0.1,5,5,#True)
SetColor(#Red)
Axes(1.0,1.0,5.0,5.0,5,5,#True)
SetColor(#Black)
Label_Axes(1.0,0.5)
TopTitle("Sinc Function")
XAxisTitle("x (radians)")
YAxisTitle("Sin(x/x*x)")
;SetWorldClipOn()
x = -5
SetColor($D99E7C)
Move(x,sinc(x))
x = x + 0.5
Repeat
Draw(x,sinc(x)+1)
INC(x, 0.5)
Until x > 20.0
; SetColor(#Black)
; SetBkColor(#White)
; ClearDevice()
; ClearViewPort()
;
; SetColor(#AlizarinCrimson)
; SetFillStyle(#HatchFill, #BeauBlue)
; ;SetLineStyle(#SolidLn, #SolidFill, 1)
; ;SetBkColor(#AlizarinCrimson)
; MaxX=GetMaxX(): MaxY=GetMaxY()
; MaxRadius = MaxY / 10
; FillEllipse((MaxX)-100,(MaxY)-100,(MaxRadius),(MaxRadius))
;
; ;SetFillStyle(#NoFill, #ArmyGreen)
; SetColor(#ArmyGreen)
; ;SetFillStyle(#HatchFill, #BeauBlue)
; ;SetLineStyle(#SolidLn, #SolidFill, 1)
; Lines(250, 250,400, 400)
; ;$00F5C71A
; DrawSymbol(200, 200, #DeepLemon, #SYMBOLRECTANGLE, 30, 30)
;
; SetFillStyle(#NoFill, #ArmyGreen)
; SetColor(#AlizarinCrimson)
; SetFillStyle(#HatchFill, #ArmyGreen)
; ;SetLineStyle(#SolidLn, #SolidFill, 1)
; Sector(100,100, 20,90, 220,20)
;
; SetColor(#AlizarinCrimson)
; ;SetBkColor(#White)
; OutTextXY(10,10, "dlfdsf dsf sd kdlsfs fkdsf dsf ds")
Repeat
Event = WaitWindowEvent()
If Event = #PB_Event_CloseWindow ; If the user has pressed on the close button
Quit = 1
EndIf
Until Quit = 1
EndIf
End ; All the opened windows are closed automatically by PureBasic
Last edited by startup on Sat Sep 19, 2015 3:26 pm, edited 1 time in total.
Re: Help on an error - bgi graphics, function plot modules
i am sorry, i posted an old plot module
the new one below
the new one below
Re: Help on an error - bgi graphics, function plot modules
Code: Select all
XIncludeFile "MINIBGI.pbi"
DeclareModule MINIPLOT
EnableExplicit
#MAXINTEGER = 65535
; sets clipping of plotting on: i.e. only within actual plot region
; delimited by XMin->XMax And YMin->YMax
Declare SetClipOn()
; sets clipping of plotting off: i.e. can plot anywhere on the screen,
; but window is still delimited by XMin->XMax And YMin->YMax
Declare SetClipOff()
; clears a status line at the very top of the screen;
; you have To be in graphics mode For this To work.
Declare Clear_StatusLine()
; writes out a status line "Message" after clearing the status line
; you have To be in graphics mode For this To work.
Declare Write_StatusLine(Message.s)
; defines constants (XAxisScale,YAxisScale,ConstX,ConstY) which are used
; To convert To And from world And window coordinate systems.
Declare Setscale(WXMin.d,WXMax.d,WYMin.d,WYMax.d)
;performs transformation from world coordinates to window (screen) coordinates
Declare World_to_Window(x.d,y.d, *XScreen.integer, *YScreen.integer)
; performs transformation from window (screen) coordinates To world
; coordinates
Declare Window_to_World(XScreen.i,YScreen.i, *x.double, *y.double)
; move graphics cursor To world coordinate X,Y
Declare Move(X.d,Y.d)
; draw line from present position of graphics cursor To world
; coordinate X,Y; use BGI Declare SetLineStyle to change from
; solid To dotted, dashed, etc
Declare Draw(X.d,Y.d)
; move graphics cursor a relative distance (in world coordinates) from
; present position
Declare RelMove(X.d,Y.d)
; draw line from present position of graphics cursor To a new
; position given by the relative distance X,Y (in world coordinates)
; use BGI Declare SetLineStyle To change from solid To dotted,
; dashed, etc
Declare RelDraw(X.d,Y.d)
; Draws tick marks For "axes" And "frame" With minor tick intervals
; every XTick,YTick, And major ticks every XMajor,YMajor minor ticks.
; Tick_Proc checks If x And y axes are running the conventional directions
; (i.e. xmin->max is left To right And ymin->ymax is up) And acts accordingly;
; This routine is only used internally by HiGraf.
Declare Tick_Proc(Xarg.d,Yarg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; draws a frame around box determined by XMin,XMax And YMin,YMax;
; put minor ticks every XTick,YTick interval With major ticks every
; XMajor,YMajor multiples of XTick,YTick; if GridOn = TRUE a grid
; is drawn
Declare Frame(XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; puts STRING Labl at the top of the plot
Declare TopTitle(Labl.s)
; labels x axis With STRING Labl; Label_Axes sets up variable MaxLabHeight
; which is used For XAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabHeight To 0;
Declare XAxisTitle(Labl.s)
; labels y axis With STRING Labl; Label_Axes sets up variable MaxLabLength
; which is used For YAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabLength To 0;
Declare YAxisTitle(Labl.s)
; This Declare draws a label at position X,Y in world coordinates;
; the variables "Font,Direction,Size,XJust,YJust" are just As in the
; BGI description For Turbo Pascal graphics:
; Font,Direction, And Size are set by a BGI proc "SetTextStyle" And
; XJust,YJust are set by a BGI proc "SetTextJustify"
Declare Draw_Label(X.d,Y.d, Strng.s,Font.i,Direction.i,Size.i, XJust.i,YJust.i)
; Draws a pair of axes through XOrg,YOrg With minor tick intervals
; XTick,YTick, And major ticks every XMajor,YMajor minor tick
; intervals; if the flag GridOn = TRUE then a grid is drawn
Declare Axes(XOrg.d,YOrg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
; Labels axes at intervals LabelX, LabelY; by convention you may
; want this To be :
; LabelX = XMajor*XTick
; LabelY = YMajor*YTick
; in your program
Declare Label_Axes(LabelX.d,LabelY.d)
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Declare PlotPoint(X.d,Y.d, Symbol.i, SymSize.i, color.i)
; Declare To set up the graph limits.
; The world coordinate limits are XMin, XMax, YMin, And YMax.
; The window limits are WXMin, WXMax, WYMin, WYMax expressed As
; fractions (of 1,i.e. 0.95 etc) of the maximum screen limits.
Declare Setup_Graph(XMin.d,XMax.d,YMin.d,YMax.d, WXMin.d,WXMax.d,WYMin.d,WYMax.d,logx.b,logy.b)
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; error bar on X,Y are sigx and sigy; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Declare PlotData(x.d,sigx.d,y,sigy.d, Symbol.i, SymSize.i, color.i)
EndDeclareModule
Module MINIPLOT
EnableExplicit
UseModule MINIBGI
Global.l Dim Custom_LineStyle(5)
Global.d XWorldMin, XWorldMax,YWorldMin, YWorldMax ; global variables for world limits
Global.i XWindMin, XWindMax, YWindMin, YWindMax ; global variables for window limits
Global.i XViewMax,YViewMax ; viewport limits
Global.d XAxisScale, YAxisScale ; factors for converting
Global.i ConstX, ConstY ; to screen coordinates
Global.b XAxisLog, YAxisLog ; global variables for axis type
Global.i MaxLabLength ; y axis label length in pixels; used To calculate y axis title offset
Global.i MaxLabHeight ; x axis label height in pixels; used To calculate x axis title offset
Global.i MaxColor ; store GetMaxColor value
; sets clipping of plotting on: i.e. only within actual plot region
; delimited by XMin->XMax And YMin->YMax
Procedure SetClipOn()
SetViewPort(XWindMin,YWindMin,XWindMax,YWindMax,#ClipOn)
EndProcedure
; sets clipping of plotting off: i.e. can plot anywhere on the screen,
; but window is still delimited by XMin->XMax And YMin->YMax
Procedure SetClipOff()
SetViewPort(XWindMin,YWindMin,XWindMax,YWindMax,#ClipOff)
EndProcedure
; clears a status line at the very top of the screen;
; you have To be in graphics mode For this To work.
Procedure Clear_StatusLine()
Protected.i Status_Width = 12 ; is status line 12 pixels tall?
SetViewPort(0,0,GetMaxX(),GetMaxY(),#ClipOff)
SetFillStyle(#EmptyFill,GetMaxColor())
Bar(0,0,GetMaxX(),Status_Width)
SetClipOn()
EndProcedure
; writes out a status line "Message" after clearing the status line
; you have To be in graphics mode For this To work.
Procedure Write_StatusLine(Message.s)
Clear_StatusLine()
SetViewPort(0,0,GetMaxX(),GetMaxY(),#ClipOff)
SetTextStyle(#ArialFont,#HorizDir,6)
SetTextJustify(#LeftText,#TopText)
MoveTo(0,0)
OutText(Message)
SetClipOn()
MoveTo(1,2)
EndProcedure
; defines constants (XAxisScale,YAxisScale,ConstX,ConstY) which are used
; To convert To And from world And window coordinate systems.
Procedure Setscale(WXMin.d,WXMax.d,WYMin.d,WYMax.d)
XWindMin = Round(WXMin*GetMaxX()/100.0, #PB_Round_Up)
XWindMax = Round(WXMax*GetMaxX()/100.0, #PB_Round_Up)
YWindMin = Round(WYMin*GetMaxY()/100.0, #PB_Round_Up)
YWindMax = Round(WYMax*GetMaxY()/100.0, #PB_Round_Up)
XViewMax = XWindMax-XWindMin
YViewMax = YWindMax-YWindMin
If XAxisLog
XAxisScale = XViewMax /(Log10(XWorldMax)-Log10(XWorldMin))
ConstX = -Round(Log10(XWorldMin)*XAxisScale, #PB_Round_Up)
Else
XAxisScale = XViewMax/(XWorldMax-XWorldMin)
ConstX = -Round(XWorldMin*XAxisScale, #PB_Round_Up)
EndIf
If YAxisLog
YAxisScale = YViewMax/(Log10(YWorldMin)-Log10(YWorldMax))
ConstY = -Round(Log10(YWorldMax)*YAxisScale, #PB_Round_Up)
Else
YAxisScale = YViewMax/(YWorldMin-YWorldMax)
ConstY = -Round(YWorldMax*YAxisScale, #PB_Round_Up)
EndIf
EndProcedure
;performs transformation from world coordinates to window (screen) coordinates
Procedure World_to_Window(x.d,y.d, *XScreen.integer, *YScreen.integer)
Protected.d temp
Protected.i isign
If XAxisLog
If (x > 0.0)
x = Log10(x)
Else
x = Log10(XWorldMin)
EndIf
EndIf
If YAxisLog
If (y > 0.0)
y = Log10(y)
Else
y = Log10(YWorldMin)
EndIf
EndIf
temp = x * XAxisScale + ConstX
isign = Sign(temp)
If isign*temp < #MAXINTEGER
*XScreen\i = Round(temp, #PB_Round_Up)
Else
*XScreen\i = isign*#MAXINTEGER
EndIf
temp = y * YAxisScale + ConstY
isign = Sign(temp)
If isign*temp < #MAXINTEGER
*YScreen\i = Round(temp, #PB_Round_Up)
Else
*YScreen\i = isign*#MAXINTEGER
EndIf
EndProcedure
; performs transformation from window (screen) coordinates To world
; coordinates
Procedure Window_to_World(XScreen.i,YScreen.i, *x.double, *y.double)
*x\d = (1.0*XScreen-ConstX)/XAxisScale
*y\d = (1.0*YScreen-ConstY)/YAxisScale
If XAxisLog
*x\d = Pow(10.0,*x)
EndIf
If YAxisLog
*y\d = Pow(10.0,*y)
EndIf
EndProcedure
; move graphics cursor To world coordinate X,Y
Procedure Move(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
MoveTo(xs,ys)
EndProcedure
; draw line from present position of graphics cursor To world
; coordinate X,Y; use BGI procedure SetLineStyle to change from
; solid To dotted, dashed, etc
Procedure Draw(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
LineTo(xs,ys)
EndProcedure
; move graphics cursor a relative distance (in world coordinates) from
; present position
Procedure RelMove(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
MoveRel(xs,ys)
EndProcedure
; draw line from present position of graphics cursor To a new
; position given by the relative distance X,Y (in world coordinates)
; use BGI Procedure SetLineStyle To change from solid To dotted,
; dashed, etc
Procedure RelDraw(X.d,Y.d)
Protected xs.i,ys.i
World_to_Window(X,Y,@xs,@ys)
LineRel(xs,ys)
EndProcedure
; Draws tick marks For "axes" And "frame" With minor tick intervals
; every XTick,YTick, And major ticks every XMajor,YMajor minor ticks.
; Tick_Proc checks If x And y axes are running the conventional directions
; (i.e. xmin->max is left To right And ymin->ymax is up) And acts accordingly;
; This routine is only used internally by HiGraf.
Procedure Tick_Proc(Xarg.d,Yarg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
Protected.d XTick_scale = 0.015 ; scale factors for tick lengths
Protected.d YTick_scale = 0.005
Protected.d x, y, decade, tempmin, tempmax
Protected.i ticklen, i
; draw x axis tick marks
ticklen = Round(XTick_scale*GetMaxY(), #PB_Round_Up)
If XWorldMin <= XWorldMax ; normal axis direction
tempmin = XWorldMin
tempmax = XWorldMax
Else ; axis is reversed from normal
tempmin = XWorldMax
tempmax = XWorldMin
EndIf
If XAxisLog ; x axis is logarithmic
decade = Pow(10.0,Log(tempmin)) ; get next lower decade
Repeat
Move(decade,Yarg)
LineRel(0,2*ticklen)
LineRel(0,-4*ticklen)
If GridOn
Move(decade,YWorldMin)
Draw(decade,YWorldMax)
EndIf
For i = 2 To 9
x = decade*i
If x<= tempmax
Move(x,Yarg)
LineRel(0,ticklen)
LineRel(0,-2*ticklen)
EndIf
If GridOn
SetLineStyle(#DottedLn,0,1) ; fine dotted line
Move(x,YWorldMin)
Draw(x,YWorldMax)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
Next
decade = decade*10.0
Until (decade > tempmax)
ElseIf XTick > 0.0 ; x axis is linear
x = tempmin+XTick
i = 1
Repeat
Move(x,Yarg)
If (i % XMajor) = 0
LineRel(0,2*ticklen)
LineRel(0,-4*ticklen)
Else
LineRel(0,ticklen)
LineRel(0,-2*ticklen)
EndIf
If GridOn
If (i % XMajor) <> 0
SetLineStyle(#DottedLn,0,1)
EndIf ; fine dotted line
Move(x,YWorldMin)
Draw(x,YWorldMax)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
INC(x, XTick)
INC(i)
Until (x > tempmax)
EndIf ; ELSE IF (XTick...
; draw y axis tick marks
ticklen = Round(YTick_scale*GetMaxX(), #PB_Round_Up)
If YWorldMin <= YWorldMax ; normal axis direction
tempmin = YWorldMin
tempmax = YWorldMax
Else ; axis is reversed from normal
tempmin = YWorldMax
tempmax = YWorldMin
EndIf
If YAxisLog ; y axis is logarithmic
decade = Pow(10.0,Log(tempmin)) ; get next lowest decade
Repeat
Move(Xarg,decade)
LineRel(-2*ticklen,0)
LineRel(4*ticklen,0)
If GridOn
Move(XWorldMin,decade)
Draw(XWorldMax,decade)
EndIf
For i = 2 To 9
y = decade*i
If y <= tempmax
Move(Xarg,y)
LineRel(-ticklen,0)
LineRel(2*ticklen,0)
EndIf
If GridOn
SetLineStyle(#DottedLn,0,1) ; fine dotted line
Move(XWorldMin,y)
Draw(XWorldMax,y)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
Next
decade = decade*10.0
Until (decade > tempmax)
ElseIf YTick > 0.0 ; y axis is linear
y = tempmin+YTick
i = 1
Repeat
Move(Xarg,y)
If (i % YMajor) = 0
LineRel(-2*ticklen,0)
LineRel(4*ticklen,0)
Else
LineRel(-ticklen,0)
LineRel(2*ticklen,0)
EndIf
If GridOn
If (i % YMajor) <> 0
SetLineStyle(#DottedLn,0,1)
EndIf ; fine dotted line
Move(XWorldMin,y)
Draw(XWorldMax,y)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
INC(y,YTick)
INC(i)
Until y > tempmax
EndIf
EndProcedure
; draws a frame around box determined by XMin,XMax And YMin,YMax;
; put minor ticks every XTick,YTick interval With major ticks every
; XMajor,YMajor multiples of XTick,YTick; if GridOn = TRUE a grid
; is drawn
Procedure Frame(XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
SetClipOff()
; draw frame around world
Move(XWorldMin,YWorldMin)
Draw(XWorldMax,YWorldMin)
Draw(XWorldMax,YWorldMax)
Draw(XWorldMin,YWorldMax)
Draw(XWorldMin,YWorldMin)
SetClipOn()
; add tick marks
Tick_Proc(XWorldMin,YWorldMin,XTick,YTick,XMajor,YMajor,GridOn)
Tick_Proc(XWorldMax,YWorldMax,XTick,YTick,XMajor,YMajor,GridOn)
EndProcedure
Procedure.s Remove_Zeros(Strng.s)
Protected.i i,j,z
Protected.s tmp1,tmp2
Protected.s signs
Strng = Trim(Strng)
i = Len(Strng)
If (Mid(Strng,i-3,i) = "E+0") Or (Mid(Strng,i-3,i) = "E-0")
Strng = Mid(Strng,0,i-4)
i = Len(Strng)
ElseIf (Mid(Strng,i-4,i) = "E+00") Or (Mid(Strng,i-4,i) = "E-00")
Strng = Mid(Strng,0,i-5)
i = Len(Strng)
ElseIf (Mid(Strng,i-5,i) = "E+000") Or (Mid(Strng,i-5,i) = "E-000")
Strng = Mid(Strng,0,i-6)
i = Len(Strng)
ElseIf (Mid(Strng,i-6,i) = "E+0000") Or (Mid(Strng,i-6,i) = "E-0000")
Strng = Mid(Strng,0,i-7)
i = Len(Strng)
EndIf
z = FindString(Strng, "E", 1, #PB_String_NoCase)
If z > 0
tmp1 = Mid(Strng,0,z-1)
If Mid(Strng,z+1,1) = "+"
signs = "E+"
tmp2 = Mid(Strng,z+2,i)
ElseIf Mid(Strng,z+1,1) = "-"
signs = "E-"
tmp2 = Mid(Strng,z+2,i)
Else
tmp2 = Mid(Strng,z+1,i)
EndIf
i = Len(tmp1)
If i > 0
While i > 0
If (Mid(tmp1,i-1,1) = " ") Or (Mid(tmp1,i-1,1) = "0")
;tmp1[i-1] = Chr(0)
tmp1 = Mid(tmp1,0,i)
DEC(i)
Else
Break
EndIf
Wend
EndIf
i = Len(tmp1)
If Mid(tmp1,i-1,1) = "."
tmp1 = Mid(tmp1,0,i-2)
EndIf
; start exponent
i = -1
j = Len(tmp2)
If j > 0
While i < j
If (Mid(tmp2,i+1,1) = " ") Or (Mid(tmp2,i+1,1) = "0")
INC(i)
Else
Break
EndIf
Wend
EndIf
If i >= 0
tmp2 = Mid(tmp2,i+1,j)
EndIf
tmp1 = tmp1 + signs
tmp1 = tmp1 + tmp2
Strng = tmp1;
Else ; regular number such as 20.0000
z = FindString(Strng, ".", 1, #PB_String_NoCase)
If z > 0
i = Len(Strng)
If i > 0
While i > 0
If (Mid(Strng,i-1,1) = " ") Or (Mid(Strng,i-1,1) = "0")
Strng = Mid(Strng,0,i-1)
DEC(i)
Else
Break
EndIf
Wend
EndIf
i = Len(Strng)
If Mid(Strng,i-1,1) = "."
Strng = Mid(Strng,0,i-2)
EndIf
EndIf
EndIf
ProcedureReturn Strng
EndProcedure
; puts STRING Labl at the top of the plot
Procedure TopTitle(Labl.s)
Protected.i scale = 24
Protected.i xw,yw
SetClipOff()
xw = XViewMax / 2
yw = -scale;
SetTextStyle(#CourierNewFont,#HorizDir,16)
SetTextJustify(#CenterText,#BottomText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; labels x axis With STRING Labl; Label_Axes sets up variable MaxLabHeight
; which is used For XAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabHeight To 0;
Procedure XAxisTitle(Labl.s)
Protected.i scale = 12
Protected.i xw,yw
SetClipOff()
xw = XViewMax / 2
yw = YViewMax+MaxLabHeight+scale+16;
SetTextStyle(#CourierNewFont,#HorizDir,16)
SetTextJustify(#CenterText,#TopText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; labels y axis With STRING Labl; Label_Axes sets up variable MaxLabLength
; which is used For YAxisTitle offset; if you haven't called Label_Axes,
; Setup_Graph has initialized MaxLabLength To 0;
Procedure YAxisTitle(Labl.s)
Protected.i scale = 34
Protected.i xw,yw
SetClipOff()
xw = -MaxLabLength-scale ; adjust position for length of y axis number labels
yw = YViewMax / 2
SetTextStyle(#CourierNewFont, #VertDir, 16)
SetTextJustify(#RightText, #CenterText)
OutTextXY(xw,yw,Labl)
SetClipOn()
EndProcedure
; This Procedure draws a label at position X,Y in world coordinates;
; the variables "Font,Direction,Size,XJust,YJust" are just As in the
; BGI description For Turbo Pascal graphics:
; Font,Direction, And Size are set by a BGI proc "SetTextStyle" And
; XJust,YJust are set by a BGI proc "SetTextJustify"
Procedure Draw_Label(X.d,Y.d, Strng.s,Font.i,Direction.i,Size.i, XJust.i,YJust.i)
Protected.i xw,yw
SetTextJustify(XJust,YJust)
SetTextStyle(Font,Direction,Size)
World_to_Window(X,Y,@xw,@yw)
OutTextXY(xw,yw,Strng)
EndProcedure
; Draws a pair of axes through XOrg,YOrg With minor tick intervals
; XTick,YTick, And major ticks every XMajor,YMajor minor tick
; intervals; if the flag GridOn = TRUE then a grid is drawn
Procedure Axes(XOrg.d,YOrg.d,XTick.d,YTick.d, XMajor.i,YMajor.i, GridOn.b)
SetClipOn()
Move(XOrg,YWorldMin)
Draw(XOrg,YWorldMax) ; x axis
Move(XWorldMin,YOrg)
Draw(XWorldMax,YOrg) ; y axis
Tick_Proc(XOrg,YOrg,XTick,YTick,XMajor,YMajor,GridOn) ; draw tick marks
EndProcedure
; Labels axes at intervals LabelX, LabelY; by convention you may
; want this To be :
; LabelX = XMajor*XTick
; LabelY = YMajor*YTick
; in your program
Procedure Label_Axes(LabelX.d,LabelY.d)
Protected.i x_location = 8 ; factors for positioning labels
Protected.i y_location = 8
Protected.i xloc,yloc,templength,tempheight
Protected.d tempminx,tempmaxx,tempminy,tempmaxy
Protected.d x,y
Protected.s labl
SetClipOff()
SetTextStyle(#TimesNewRomanFont,#HorizDir,2)
If XWorldMin <= XWorldMax ; regular axis direction
If XAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMin,@xloc,@yloc)
Window_to_World(xloc-1,yloc,@tempminx,@y)
World_to_Window(XWorldMax,YWorldMin,@xloc,@yloc)
Window_to_World(xloc+1,yloc,@tempmaxx,@y)
Else ; X axis is linear
tempminx = XWorldMin
tempmaxx = XWorldMax
EndIf
Else ; reversed axis direction
If XAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMax,YWorldMin,@xloc,@yloc)
Window_to_World(xloc+1,yloc,@tempminx,@y)
World_to_Window(XWorldMin,YWorldMin,@xloc,@yloc)
Window_to_World(xloc-1,yloc,@tempmaxx,@y)
Else ; X axis is linear
tempminx = XWorldMax
tempmaxx = XWorldMin
EndIf
EndIf
If YWorldMin <= YWorldMax ; regular axis direction
If YAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMin,@xloc,@yloc)
Window_to_World(xloc,yloc+1,@x,@tempminy)
World_to_Window(XWorldMin,YWorldMax,@xloc,@yloc)
Window_to_World(xloc,yloc-1,@x,@tempmaxy)
Else ; Y axis is linear
tempminy = YWorldMin
tempmaxy = YWorldMax
EndIf
Else ; reversed axis direction
If YAxisLog
; adjust limits to ensure end labels are shown
World_to_Window(XWorldMin,YWorldMax,@xloc,@yloc)
Window_to_World(xloc,yloc-1,@x,@tempminy)
World_to_Window(XWorldMin,YWorldMin,@xloc,@yloc)
Window_to_World(xloc,yloc+1,@x,@tempmaxy)
Else ; Y axis is linear
tempminy = YWorldMax
tempmaxy = YWorldMin
EndIf
EndIf
; label x axis
MaxLabHeight = 0; ; initialize this offset for XAxisTitle
tempheight = 0;
SetTextJustify(#CenterText,#TopText) ; do this just once for linear axis
x = tempminx
If XAxisLog
x = Pow(10.0,Log10(tempminx))
EndIf
While x <= tempmaxx
If XAxisLog
labl = StrD(Log10(x), 3) ; was 6
Else
labl = StrD(x, 3) ; was 5
EndIf
labl = Trim(labl)
labl = Remove_Zeros(labl)
World_to_Window(x,YWorldMin,@xloc,@yloc)
If XAxisLog ; do an exponentiated label
If (x >= tempminx) And (x <= tempmaxx)
SetTextJustify(#CenterText,#TopText)
INC(yloc,y_location) ; position the "10"
OutTextXY(xloc,yloc,"10")
tempheight = TextHeights("10")
DEC(yloc,(tempheight / 2))
INC(xloc,Int((TextWidths("10") / 2))+3)
tempheight = (tempheight / 2) + Int(TextHeights(labl)) ; pixel height of label
SetTextJustify(#LeftText,#TopText)
OutTextXY(xloc,yloc,labl)
EndIf ; IF ((x >= tempminx...
x = x*10.0
Else ; straight linear label
INC(yloc,y_location)
OutTextXY(xloc,yloc,labl)
tempheight = TextHeights(labl)
INC(x+LabelX)
EndIf ; IF (XAxisLog)...
If tempheight > MaxLabHeight
MaxLabHeight = tempheight
EndIf
Wend ; WHILE
; label y axis
MaxLabLength = 0 ; initialize this offset for YAxisTitle
templength = 0
SetTextJustify(#RightText,#CenterText)
y = tempminy
If YAxisLog
y = Pow(10.0,Log10(tempminy))
EndIf
While y <= tempmaxy
If YAxisLog
labl = StrD(Log10(y), 3) ; was 6
Else
labl = StrD(y, 3) ; was 5
EndIf
labl = Trim(labl)
labl = Remove_Zeros(labl)
World_to_Window(XWorldMin,y,@xloc,@yloc)
If YAxisLog ; do an exponentiated label
If (y >= tempminy) And (y <= tempmaxy)
SetTextJustify(#RightText,#CenterText)
templength = TextWidths("10")
DEC(xloc,x_location-templength) ; position the "10"
OutTextXY(xloc,yloc,"10")
templength = templength+Int(TextWidths(labl)) ; pixel width of label
DEC(yloc,Int(TextHeights("10") / 2))
INC(xloc,2)
SetTextJustify(#LeftText,#CenterText)
OutTextXY(xloc,yloc,labl)
EndIf ; IF ((y >= tempminy...
y = y*10.0
Else ; straight linear label
DEC(xloc,x_location)
OutTextXY(xloc,yloc,labl)
templength = TextWidths(labl)
INC(y,LabelY)
EndIf
If (templength > MaxLabLength)
MaxLabLength = templength
EndIf
Wend
; restore defaults
SetClipOn()
EndProcedure
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Procedure PlotPoint(X.d,Y.d, Symbol.i, SymSize.i, color.i)
Protected.i del = 1
Protected.i xs,ys,delta,x1,y1
Protected.i curcol
x1 = GetX()
y1 = GetY()
curcol = GetColor()
SetColor(color)
World_to_Window(X,Y,@xs,@ys)
delta = del*SymSize;
Select Symbol
Case 1 ; plus
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
MoveRel(-delta,-delta)
LineRel(0,2*delta)
Case 2 ; box
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,0)
LineRel(0,2*delta)
LineRel(-2*delta,0)
LineRel(0,-2*delta)
Case 3 ; cross
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,2*delta)
MoveRel(-2*delta,0)
LineRel(2*delta,-2*delta)
Case 4: ; triangle
MoveTo(xs,ys-delta-delta / 3)
LineRel(-delta,2*delta)
LineRel(2*delta,0)
LineRel(-delta,-2*delta)
Case 5 ; inverted triangle
MoveTo(xs,ys+delta+delta / 3)
LineRel(-delta,-2*delta)
LineRel(2*delta,0)
LineRel(-delta,2*delta)
Case 6
Circles(xs,ys,delta) ; open circle
Case 7
FillEllipse(xs,ys,delta,delta) ; closed circle
Case 8
PutPixel(xs,ys,GetMaxColor()) ; unscaled point
Default
EndSelect
MoveTo(x1,y1)
SetColor(curcol)
EndProcedure
; Procedure To set up the graph limits.
; The world coordinate limits are XMin, XMax, YMin, And YMax.
; The window limits are WXMin, WXMax, WYMin, WYMax expressed As
; fractions (of 1,i.e. 0.95 etc) of the maximum screen limits.
Procedure Setup_Graph(XMin.d,XMax.d,YMin.d,YMax.d, WXMin.d,WXMax.d,WYMin.d,WYMax.d,logx.b,logy.b)
If logx = #True
XAxisLog = #True
Else
XAxisLog = #False
EndIf
If logy = #True
YAxisLog = #True
Else
YAxisLog = #False
EndIf
; set global variables for other graphics routines.
XWorldMin = XMin
XWorldMax = XMax
YWorldMin = YMin
YWorldMax = YMax
Setscale(WXMin,WXMax,WYMin,WYMax)
; initialize some global constants just in case Label_Axes is not called
MaxLabLength = 0
MaxLabHeight = 0
; set up defaults for graphics parameters
SetClipOn()
Custom_LineStyle(0) = $0FFFF
Custom_LineStyle(1) = $5555
Custom_LineStyle(2) = $0F0F
Custom_LineStyle(3) = $1111
Custom_LineStyle(4) = $1010
EndProcedure
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; error bar on X,Y are sigx and sigy; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Procedure PlotData(x.d,sigx.d,y,sigy.d, Symbol.i, SymSize.i, color.i)
Protected.i del = 1
Protected.i xs,ys,delta,xx,yy
PlotPoint(x,y,Symbol,SymSize, color)
delta = del*SymSize
xx = GetX()
yy = GetY()
If (sigx > 0.0) ; do x error bar
Move(x+sigx,y)
Draw(x-sigx,y)
World_to_Window(x+sigx,y,@xs,@ys)
MoveTo(xs,ys-delta)
LineRel(0,2*delta)
World_to_Window(x-sigx,y,@xs,@ys)
MoveTo(xs,ys-delta)
LineRel(0,2*delta)
EndIf
If (sigy > 0.0) ; do y error bar
Move(x,y+sigy)
Draw(x,y-sigy)
World_to_Window(x,y+sigy,@xs,@ys)
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
World_to_Window(x,y-sigy,@xs,@ys)
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
EndIf
MoveTo(xx,yy)
EndProcedure
EndModule
Re: Help on an error - bgi graphics, function plot modules
problem solved.
embarrassingly i gave the wron parameters in the test program
both modules work as expected
embarrassingly i gave the wron parameters in the test program
both modules work as expected
-
Stephane Fonteyne
- User
- Posts: 27
- Joined: Sun Sep 06, 2015 2:22 pm
Re: Help on an error - bgi graphics, function plot modules
Can you please post the complete modules and main program in zip because I can not compiled itstartup wrote:problem solved.
embarrassingly i gave the wron parameters in the test program
both modules work as expected
Kind regards
Stephane
Re: Help on an error - bgi graphics, function plot modules
Hi,
there are all necesarry 3 files provided here.
Only one point:
#_Black and #_White should be #Black and #White.
Bernd
there are all necesarry 3 files provided here.
Only one point:
#_Black and #_White should be #Black and #White.
Bernd
Re: Help on an error - bgi graphics, function plot modules
Maybe I found a small typo in MiniPlot.pbi:
should be
Else y is an integer instead of a double
And do you really mean
Then you can also write Sin(x)
I think you mean
But sinc(x) should be
Or:
And it looks that something with Tick_Proc() is wrong.
They are not symetric arround the Axis.
Bernd
Code: Select all
Procedure PlotData(x.d, sigx.d, y, sigy.d, Symbol.i, SymSize.i, color.i)
Code: Select all
Procedure PlotData(x.d, sigx.d, y.d, sigy.d, Symbol.i, SymSize.i, color.i)
And do you really mean
Code: Select all
Sin(x / x * x)I think you mean
Code: Select all
Sin(x / (x * x))Code: Select all
Procedure.d sinc(x.d)
If x = 0.0
ProcedureReturn 1.0
Else
ProcedureReturn Sin(#PI * x) / (#PI * x)
EndIf
EndProcedure
Code: Select all
Procedure.d si(x.d)
If x = 0.0
ProcedureReturn 1.0
Else
ProcedureReturn Sin(x) / x
EndIf
EndProcedure
They are not symetric arround the Axis.
Bernd
Re: Help on an error - bgi graphics, function plot modules
Neat, seem like you played with it – I hope the description are sufficient.
Well thank you all for your help and suggestions and yes, you are wright with the things you wrote. I was glad to get that thingy working since I needed the viewport and clipping features for some things.
Maybe you guys can use the modules too for something. If .you can better something please post it.
Well thank you all for your help and suggestions and yes, you are wright with the things you wrote. I was glad to get that thingy working since I needed the viewport and clipping features for some things.
Maybe you guys can use the modules too for something. If .you can better something please post it.
Re: Help on an error - bgi graphics, function plot modules
Hi,
I tried to fix Tick_Proc()
At the moment only for linear axis.
Up to now I never tried log axis.
Please test it.
Bernd
I tried to fix Tick_Proc()
Code: Select all
Procedure Tick_Proc(Xarg.d, Yarg.d, XTick.d, YTick.d, XMajor.i, YMajor.i, GridOn.i)
Protected.d XTick_scale = 0.015 ; scale factors for tick lengths
Protected.d YTick_scale = 0.005
Protected.d x, y, decade, tempmin, tempmax
Protected.i ticklen, i
; draw x axis tick marks
ticklen = Round(XTick_scale * GetMaxY(), #PB_Round_Up)
If XWorldMin <= XWorldMax ; normal axis direction
tempmin = XWorldMin
tempmax = XWorldMax
Else ; axis is reversed from normal
tempmin = XWorldMax
tempmax = XWorldMin
EndIf
If XAxisLog ; x axis is logarithmic
decade = Pow(10.0,Log(tempmin)) ; get next lower decade
Repeat
Move(decade,Yarg)
LineRel(0,2*ticklen)
LineRel(0,-4*ticklen)
If GridOn
Move(decade,YWorldMin)
Draw(decade,YWorldMax)
EndIf
For i = 2 To 9
x = decade*i
If x<= tempmax
Move(x,Yarg)
LineRel(0,ticklen)
LineRel(0,-2*ticklen)
EndIf
If GridOn
SetLineStyle(#DottedLn,0,1) ; fine dotted line
Move(x,YWorldMin)
Draw(x,YWorldMax)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
Next
decade = decade*10.0
Until (decade > tempmax)
ElseIf XTick > 0.0 ; x axis is linear
x = tempmin
While x < tempmin + XTick
If Int(x) % XMajor <> 0
x = Int(x) + 1
Else
Break
EndIf
Wend
Repeat
Move(x,Yarg)
If (Int(x) % XMajor) = 0
LineRel(0,2*ticklen)
LineRel(0,-4*ticklen)
Else
LineRel(0,ticklen)
LineRel(0,-2*ticklen)
EndIf
If GridOn
If (Int(x) % XMajor) <> 0
SetLineStyle(#DottedLn, 0, 1) ; fine dotted line
Else
SetLineStyle(#SolidLn, 0, #NormWidth)
EndIf
Move(x, YWorldMin)
Draw(x, YWorldMax)
EndIf
INC(x, XTick)
Until (x >= tempmax)
EndIf ; ELSE IF (XTick...
; draw y axis tick marks
ticklen = Round(YTick_scale*GetMaxX(), #PB_Round_Up)
If YWorldMin <= YWorldMax ; normal axis direction
tempmin = YWorldMin
tempmax = YWorldMax
Else ; axis is reversed from normal
tempmin = YWorldMax
tempmax = YWorldMin
EndIf
If YAxisLog ; y axis is logarithmic
decade = Pow(10.0,Log(tempmin)) ; get next lowest decade
Repeat
Move(Xarg,decade)
LineRel(-2*ticklen,0)
LineRel(4*ticklen,0)
If GridOn
Move(XWorldMin,decade)
Draw(XWorldMax,decade)
EndIf
For i = 2 To 9
y = decade*i
If y <= tempmax
Move(Xarg,y)
LineRel(-ticklen,0)
LineRel(2*ticklen,0)
EndIf
If GridOn
SetLineStyle(#DottedLn,0,1) ; fine dotted line
Move(XWorldMin,y)
Draw(XWorldMax,y)
SetLineStyle(#SolidLn,0,#NormWidth)
EndIf
Next
decade = decade*10.0
Until (decade > tempmax)
ElseIf YTick > 0.0 ; y axis is linear
y = tempmin
While y < tempmin + YTick
If Int(y) % YMajor <> 0
y = Int(y) + 1
Else
Break
EndIf
Wend
Repeat
Move(Xarg, y)
If (Int(y) % YMajor) = 0
LineRel(-2*ticklen,0)
LineRel(4*ticklen,0)
Else
LineRel(-ticklen,0)
LineRel(2*ticklen,0)
EndIf
If GridOn
If (Int(y) % YMajor) <> 0
SetLineStyle(#DottedLn, 0, 1) ; fine dotted line
Else
SetLineStyle(#SolidLn, 0, #NormWidth)
EndIf
Move(XWorldMin, y)
Draw(XWorldMax, y)
EndIf
INC(y, YTick)
Until y > tempmax
EndIf
EndProcedure
Up to now I never tried log axis.
Please test it.
Bernd
Re: Help on an error - bgi graphics, function plot modules
hi bernd,
looked at your code, looked ok to me. i tried it - it looked weird and then my laptop croaked. so i write this from my sons laptop. i hope i can answer some more really soon - after the max 2 day ??? repair of asus that they promised.
thanks
richard
looked at your code, looked ok to me. i tried it - it looked weird and then my laptop croaked. so i write this from my sons laptop. i hope i can answer some more really soon - after the max 2 day ??? repair of asus that they promised.
thanks
richard
Re: Help on an error - bgi graphics, function plot modules
i could hardly believe it, but the asus people really kept their word. they came early in the morning, replace damaged memory modules it i am up and running again.
great service!
i did change some stuff in both modules, fixing errors and extending some things. see below
richard
great service!
i did change some stuff in both modules, fixing errors and extending some things. see below
richard
Re: Help on an error - bgi graphics, function plot modules
Code: Select all
DeclareModule MINIBGI
EnableExplicit
; update constants
#UpdateOff = 0
#UpdateOn = 1
#UpdateNow = 2
; clipping constants
#ClipOn = 1
#ClipOff = 0
; raster operation constants
#CopyPut = 0
#XorPut = 1
#OrPut = 2
#AndPut = 3
#NotPut = 4
#NotOrPut = 5
#InvBitOrPut = 6
#InvScrAndPut = 7
#TransPut = 8
#MaskPut = 9
#BkgPut = 10
#NormalPut = #CopyPut
; drawing modes on screen
#CopyMode = 0
#XorMode = 1
#OrMode = 2
#AndMode = 3
#NotMode = 4
#NotScrMode = 5
#NotXorMode = 6
#NotOrMode = 7
#NotAndMode = 8
#InvColAndMode = 9
#InvColOrMode = 10
#InvScrAndMode = 11
#InvScrOrMode = 12
#BlackMode = 13
#WhiteMode = 14
#EmptyMode = 15
#TRANSPARENT_ = $00
#OPAQUE_ = 16
; drawing style For lines
#SolidLn = 0
#DottedLn = 1
#DashDotLn = 2
#DashedLn = 3
#DashDotDotLn = 4
#UserBitLn = 5
#NullLn = 6
; thick constants For lines
#NormWidth = 1
#DoubleWidth = 2
#TripleWidth = 3
#QuadWidth = 4
#ThickWidth = #TripleWidth
; filling patterns
#EmptyFill = 0
#SolidFill = 1
#LineFill = 2
#ColFill = 3
#HatchFill = 4
#SlashFill = 5
#BkSlashFill= 6
#XHatchFill = 7
#UserFill = 8
#NoFill = 9
; Bar3D constants
#TopOn = 1
#TopOff = 0
; flood mode constants
#BorderFlood = 0
#SurfaceFlood = 1
; justify constants For text
#LeftText = 0
#CenterText = 1
#RightText = 2
#TopText = 0
#BottomText = 1
#BaselineText = 2
; direction constants For text
#HorizDir = 0
#VertDir = 90
; font constants For text
#CourierNewFont = 0
#MSSansSerifFont = 1
#TimesNewRomanFont= 2
#ArialFont = 3
#DefaultFont = #CourierNewFont
#ItalicFont = $1000
#UnderlineFont = $0100
#BoldFont = $0010
; Symbols for graphs
#SYMBOLRECTANGLE = 1
#SYMBOLTRIANGLE = 2
#SYMBOLDIAMOND = 3
#SYMBOLCROSS = 4
#SYMBOLXCROSS = 5
#SYMBOLNONE = 0
Structure ViewPortType
x1.w
y1.w
x2.w
y2.w
clip.l ; BOOLEAN
EndStructure
Structure PointType
x.l
y.l
EndStructure
Structure ThreeDPointType
x.d
y.d
z.d
EndStructure
Structure LineSettingsType
linestyle.w
pattern.w
thickness.w
EndStructure
Structure ArcCoordsType
x.l
y.l
xstart.i
ystart.i
xend.i
yend.i
EndStructure
Structure FillSettingsType
pattern.w
color.l
EndStructure
Structure TextSettingsType
font.w
direction.w
charsize.w
horiz.w
vert.w
EndStructure
; Global grResult.i=-1
Macro INC(i,j=1)
i + j
EndMacro
Macro DEC(i,j=1)
i - j
EndMacro
; initialization exported routines
; Clears the entire graphics screen using ClearViewPort routine. See that routine For details. Current pointer is reset
; at (0,0), that is top-left corner of the screen.
Declare ClearDevice()
; Closes the graphics window And releases all resources related To it. The parent console window is shown again in foreground
; (If any). You can Restore back the graphics window using SetGraphMode Or InitGraph.
Declare CloseGraph()
; Use CloseGraph To close the graphics window.
Declare.i InitGraph(windownumber.i, Winx.l, Winy.l, title.s)
; Sets the dimensions of the graphics window To be created by InitGraph. In this Case you must use mCustom graphics mode. (width)
; is the width And (height) is the height in pixels of the window client area. See InitGraph For more details.
; screen management exported routines
Declare ClearDeviceWithColor(color.l)
Declare ClearViewPortWithColor(color.l)
; Clears the current viewport. The current background color is used As filling color. The pointer is set at (0,0),
; that is top-left corner of the viewport. See also SetViewPort And SetBkColor For more details.
Declare ClearViewPort()
Declare GetAspectRatio(*xasp.word, *yasp.word)
; Returns the maximum x-coordinate (horizontal) in pixels. This equals the client area width minus 1. Maximum is placed on the
; right side.
Declare.i GetMaxX()
; Returns the maximum y-coordinate (vertical) in pixels. This equals the client area height minus 1. Maximum is placed on the
; bottom side.
Declare.i GetMaxY()
; Returns the current viewport And clipping settings in (viewport). You can change these settings using SetViewPort.
Declare GetViewSettings(*tviewport.ViewPortType)
; Returns the x-coordinate of the current position of the graphical pointer in pixels. It ranges between 0 And GetMaxX.
; It increases from left To right.
Declare.i GetXX()
; Returns the y-coordinate of the current position of the graphical pointer in pixels. It ranges between 0 And GetMaxY.
; It increases from top To bottom.
Declare.i GetYY()
; Sets the aspect ratio of the screen To the ratio given by xasp/yasp. It affects only routines For circular shapes. Does Not
; have a practical use other than backward compatibility With BP. Default values are (10000,10000). See also GetAspectRatio.
Declare SetAspectRatio(xasp,yasp.i)
; Sets the current output viewport To the rectangle defined by the top-left corner (x1,y1) And the bottom-right corner (x2,y2).
; If (clip) is true, anything drawn outside the viewport will be clipped (Not drawn). Coordinates specified after this call are
; relative To the top-left corner of the viewport. Cursor position is reset To (0,0). The following clipping constants are defined:
; ClipOn = #true
; ClipOff = #false
Declare SetViewPort(x1.l,y1.l,x2.l,y2.l, clip.l) ; BOOLEAN
; It specifies what binary operation is performed when drawing on screen. Argument (writemode) has two components. First
; component is the foreground mix mode. It affects contours (including lines) And filled shapes (excluding Bar). Can be one of
; the following pre-defined constants:
; CopyMode - pixels are simply copied onto the screen
; XorMode - pixels are combination of the drawing color And screen color, but Not in both (logical XOr)
; OrMode - pixels are combination of the drawing color And screen color (logical Or)
; AndMode - pixels are combination of the colors common To both the drawing And screen (logical And)
; NotMode - pixels are the inverse of the drawing color (logical Not)
; NotScrMode - pixels are the inverse of the screen color
; NotXorMode - pixels are the inverse of the XorMode color
; NotOrMode - pixels are the inverse of the OrMode color
; NotAndMode - pixels are the inverse of the AndMode color
; InvColAndMode - pixels are combination of the colors common To both the screen And the inverse of drawing color
; InvColOrMode - pixels are combination of the screen color And the inverse of drawing color
; InvScrAndMode - pixels are combination of the colors common To both the drawing And the inverse of screen color
; InvScrOrMode - pixels are combination of the drawing color And the inverse of screen color
; BlackMode - pixels are always 0
; WhiteMode - pixels are always 1
; EmptyMode - screen pixels remain unchanged
; Second component is the background mix mode. It affects only texts. Can be one of the following two pre-defined constants:
; Transparent - screen remains untouched (As in BP graph unit)
; Opaque - screen is filled With the current background color before the text is drawn
; Argument (writemode) is an Or-ed combination of the foreground And background mix modes. By Default it equals CopyMode Or Transparent.
; SetWriteMode does Not perform well on palette-based drivers, especially If the palette was Not retrived by GetSystemPalette
; routine. Anyway, because the palette is just a logical one you must use UpdateGraph routine To assure that the screen has the
; same color composition As the active page.
; You can use InvertRect To perform logical Not operations over the screen content.
Declare SetWriteMode(writemode.l)
Declare.i GetDC()
; color management exported routines
; Returns the current background color. This is a palette entry For palette-based drivers And an absolute RGB color For
; non-palette driver. Use SetBkColor To set a new color.
Declare.l GetBkColor()
; Returns the current drawing color. This is a palette entry For palette-based drivers And an absolute RGB color For
; non-palette driver. Use SetColor To set a new color.
Declare.l GetColor()
; Returns the highest color which can be set With SetColor Or other routines that accept colors. Depending on palette, this
; color is Not always White. All colors between 0 And GetMaxColor are guarantied To be valid.
; it equals FFFFFFH.
Declare.l GetMaxColor()
; Gets the pixel color of the point at position (x,y). This is a palette entry For palette-based drivers And an absolute RGB
; color For non-palette driver. To set a new color For the pixel use PutPixel.
Declare.l GetPixel(x.l,y.l)
; Returns the (Red,Green,Blue) intensity components of the color (color) in (r), (g), (b) variables. Their values range
; between 0 And 255. For example, Black returns (0,0,0). See also GetRGBColor. Parameter (color) is a palette index in
; palette-based drivers And a true RGB color For the non-palette driver.
Declare GetRGBComponents(color.l, *r.long,*g.long,*b.long, *t.long=#Null)
; Returns a maximum of 256 colors from Windows system palette. This is the palette initialized by the operating system at
; start-up. You have no guaranty that this palette is the same across all systems. In fact, it"s not.
;Declare GetSystemPalette(*palette.PaletteType)
; Sets the background color To (color). Check SetColor To learn about color values.
; The background color is the color used To clear portions of the screen (Or the entire viewport). It is also used As dual color
; in filling patterns. SetBkColor affects only subsequent drawings. Default color is Black.
Declare SetBkColor(color.l)
; Sets the foreground color To (color). For palette-based drivers the value of (color) is an index into the palette. For
; non-palette driver (color) stores a 24 bits RGB value encoded in hexadecimal form. The low-order byte contains a value For
; the relative intensity of red, the second byte contains a value For green And the third byte contains a value For blue
; (ex 0000FFH is Red). In both cases, pre-defined color names can be used instead of pure numbers. Consult InitGraph about graphics
; drivers And the section Alphabetical color names. See GetNamesPalette routine For more details on colors.
; The foreground color is the color used For drawing contours, lines And text. Other primitives have different ways To specify
; the color. Default color is White.
Declare SetColor(color.l)
; drawing primitives exported routines
; Draws part of a circle With center at (x,y), radius (radius), starting from angle (start), stopping at angle (stop).
; These angles are measured counter-clockwise. It uses current foreground color. To draw an entire circle use Circle.
Declare Arc(x.l,y.l, start.l,stop.l,radius.l)
; Draws a complete circle With center at (x,y) And radius (radius). To draw part of a circle use Arc.
; Circle is a particular Case of Ellipse.
Declare Circles(x.l,y.l, radius.l)
; Draws one Or more cubic Bezier curves, using the current foreground color. A Bezier curve is defined by two endpoints And
; two control points in between. A number of 3N+1 vertices will Define exactly N Bezier curves. The arguments are the same As in
; DrawPoly. It can be used To draw irregular curves, but a particular Case is a rotated ellipse. See RotEllipse For details.
Declare DrawBezier(nrpoints.i, Array *polypoints.PointType(1))
; Draws a polygon With (nrpoints) corner points, using the current foreground color And line style. Argument (polypoints)
; should be an Array of type PointType containing at least (nrpoints) records. No check is performed. The last corner point is
; Not drawn. It is usually faster that using several LineTo calls.
Declare DrawPoly(nrpoints.i, Array *polypoints.PointType(1))
; Draws part of an ellipse With center at (x,y). Arguments (xradius) And (yradius) are the horizontal And vertical radii of the
; ellipse, (start) And (stop) are the starting And stopping angles of the arc of the ellipse. They are measured counter-clockwise
; from the x-axis (3 o’clock is equal To 0 degrees). It uses current foreground color. To draw part of a circle use Arc.
; To draw a rotated ellipse use RotEllipse.
Declare Ellipses(x.l,y.l, start.l,stop.l,xradius.l,yradius.l)
Declare GetArcCoords(*arccoords.ArcCoordsType)
; Returns the current line settings in (lineinfo). That is, line style, pattern And thickness, As set by SetLineStyle.
Declare GetLineSettings(*lineinfo.LineSettingsType)
; Draws a line starting from (x1,y1) To (x2,y2), using the current foregroung color And line style. The current position is
; moved To (x2,y2). See LineTo For more details.
Declare Lines(x1.l,y1.l,x2.l,y2.l)
; Draws a line starting from the current pointer position To the Point (dx,dy), relative To the current position, using the
; current foreground color And line style. The current position is moved To the endpoint of the line. See LineTo For more details.
Declare LineRel(dx.l,dy.l)
; Draws a line starting from the current pointer position To the Point (x,y), using the current foregroung color And line style.
; The current position is moved To (x,y).
; Use SetLineStyle routine To set the line attributes And SetColor To set its color. Use MoveTo To change the current pointer
; position. To draw a line With absolute coordinates use Line routine instead.
Declare LineTo(x.l,y.l)
; Moves the pointer To coordinates (dx,dy), relative To the current pointer position. See MoveTo For more details.
Declare MoveRel(dx.l,dy.l)
; Moves the pointer To coordinates (x,y) which are viewport-relative. See SetViewPort For more details. Only the following
; routines use Or move the current pointer:
; ClearDevice
; ClearViewPort
; GraphDefaults
; Line
; LineRel
; LineTo
; MoveRel
; MoveTo
; OutText
; OutTextXY
; SetViewPort
; No check is made regarding coordinates range.
Declare MoveTo(x.l,y.l)
; Puts a point at position (x,y) using color (color). Check SetColor To learn about color values. Use GetPixel To retrive a
; pixel color.
Declare PutPixel(x.l,y.l, color.l)
; Draws a rectangle defined by the top-left corner (x1,y1) And the bottom-right corner (x2,y2). It uses the current foreground
; color And line style. To draw a filled rectangle use FillRect.
; Rectangle is a particular Case of DrawPoly.
Declare Rectangle(x1.l,y1.l,x2.l,y2.l)
; Draws a rotated ellipse With center at (x,y). Arguments (xradius) And (yradius) are the horizontal And vertical radii of the
; ellipse, (rot) defines the rotation angle measured counter-clockwise in degrees. It uses current foreground color. It is
; implemented using DrawBezier.
Declare RotEllipse(x.l,y.l,rot.i, xradius.i,yradius.i)
; Sets the drawing style For lines. The (linestyle) is one of the following constants:
; SolidLn - solid line
; DashedLn - dashed line
; DottedLn - dotted line
; DashDotLn - alternating dashes And dots line
; DashDotDotLn - dashes And double dots line
; UserBitLn - user defined line
; NullLn - invisible line
; If UserBitLn is specified then (pattern) should contain the 16-bit pattern. In all another cases (pattern) is ignored. The
; parameter (thickness) indicates how thick the line should be:
; NormWidth - one pixel width
; DoubleWidth - two pixels width
; TripleWidth - three pixels width
; QuadWidth - four pixels width
; ThickWidth=TripleWidth
; If (thickness) <> NormWidth then (linestyle) is ignored And the line is drawn solid, due To Windows GDI limitations.
; (thickness) is ignored For UserBitLn style because of missing implementation. Use SetColor To set the line color.
Declare SetLineStyle(linestyle.i,pattern.l,thickness.i)
; filled drawings exported routines
; Draws And fills a rectangle With opposite corners at (x1,y1) And (x2,y2), using the current fill style And color.
; This rectangle has no border. Use FillRect To draw a filled rectangle With border.
Declare Bar(x1.l,y1.l,x2.l,y2.l)
; Draws And fills a 3-dimensional bar With opposite corners of the front facet at (x1,y1) And (x2,y2). It uses the
; current foreground color. Only front facet is filled With the current fill style And color. Argument (depth) specifies
; the number of pixels used To show the depth of the bar. If (top) is true, then a 3-dimensional top is drawn.
; Its pre-defined values are
; TopOn = true
; TopOff = false
; Use Bar To draw a 2-dimensional bar.
Declare Bar3D(x1.l,y1.l,x2.l,y2.l, depth.l, top.l, col.l) ; BOOLEAN
; Draws And fills a chord (a region bounded by the intersection of an ellipse And a line segment - called a secant).
; It uses the current foreground color And fill style. The arguments have the same meaning As in Ellipse. To draw a
; sector of an ellipse use Sector.
Declare Chord(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
; Draws And fills an entire ellipse With center at (x,y). Arguments (xradius) And (yradius) are the horizontal And vertical
; radii of the ellipse. It uses the current foreground color And fill style. To draw a sector of an ellipse use Sector.
Declare FillEllipse(x.l,y.l,xradius.i,yradius.i, col.l)
; Draws And fills a polygon, using the current foreground color, line And fill style. The arguments are the same As in DrawPoly.
; The polygon is closed automatically by drawing a line from the last vertex To the first.
Declare FillPoly(nrpoints.i, Array *polypoints.PointType(1))
; Draws And fills a rectangle, using the current foreground color, line And fill style. The arguments are the same As in Rectangle.
; To draw a borderless rectangle use Bar instead.
; FillRect is a particular Case of FillPoly.
Declare FillRect(x1.l,y1.l,x2.l,y2.l, col.l)
; Fills a region surrounding the Point (x,y) Until a color-condition is met. This condition depends on (color) And the flood mode.
; This mode is set With SetFloodMode routine.
; There are some reasons this routine might fail:
; (1) the filling could Not be completed (out of memory) - unlikely
; (2) the specified point has the boundary color specified by the (color)
; parameter (in BorderFlood mode)
; (3) the specified point does Not have the color specified by (color)
; parameter (in SurfaceFlood mode)
; (4) the point is outside the current viewport, that is, it is Not visible
; See SetFloodMode For details.
Declare FloodFill(x.l,y.l, color.l)
; Returns in (fillpattern) the current fill-pattern Array. This was set using SetFillPattern routine.
Declare GetFillPattern(Array *fillpatternn.byte(1)) ;FillPatternType
; Returns the current fill-settings in (fillinfo). This Structure contains the fill pattern And color, As set by SetFillStyle routine
Declare GetFillSettings(*fillinfo.FillSettingsType)
; Performs a logical Not operation on the color values For each pixel in the specified rectangle defined by coordinates (x1,y1,x2,y2).
; On monochrome driver, InvertRect makes white pixels black And black pixels white. On color drivers, the inversion depends on
; how colors are generated. Calling InvertRect twice For the same rectangle restores the display To its previous colors. It does
; Not perform well on palette-based drivers. See also SetWriteMode.
Declare InvertRect(x1.l,y1.l,x2.l,y2.l)
; Draws And fills a circular sector (a region bounded by the intersection of a circle And two radials - called pie slice).
; It uses the current foreground color And fill style. The arguments have the same meaning As in Arc. To draw an entire disk
; use FillEllipse.
; PieSlice is a particular Case of Sector
Declare PieSlice(x.l,y.l, start.i,stop.i,radius.l)
; Draws And fills a rectangle With rounded corners, using the current foreground color, fill style And color. The argument (r)
; is the radius of a circle used To draw the corners. The other parameters are the same As in Rectangle.
Declare RoundRect(x1.l,y1.l,x2.l,y2.l,r.l)
; Draws And fills an elliptical sector (a region bounded by the intersection of an ellipse And two radials). It uses the
; current foreground color And fill style. The arguments have the same meaning As in Ellipse. To draw a sector of a circle use PieSlice.
Declare Sector(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
; Selects a user-defined fill pattern which will be used in SetFillStyle routine With UserFill hatch set. The pattern is an 8x8
; raster, corresponding To the 64 bits in (fillpattern). Foreground pattern color is set To (color). Default is White. Background
; pattern color is the background color selected by SetBkColor. Check SetColor To learn more about colors.
; Before returning it calls SetFillStyle routine To put the pattern into effect.
Declare SetFillPattern(Array fillpattern.b(1), color.l) ; FillPatternType
; Sets the filling pattern And color For filled drawings routines. Argument (pattern) can be one of the following constants:
; EmptyFill - background color hatch
; SolidFill - solid hatch
; LineFill - horizontal hatch
; ColFill - vertical hatch
; HatchFill - horizontal And vertical cross-hatch
; SlashFill - 45-degree upward, left-To-right hatch
; BkSlashFill - 45-degree downward, left-To-right hatch
; XHatchFill - 45-degree cross-hatch
; UserFill - user-defined hatch
; NoFill - no hatch
; If (pattern) equals UserFill, the user-defined pattern set by SetFillPattern becomes the active pattern. In this Case, the
; argument (color) is ignored. Parameter (color) is used To fill the shapes. Default is White. Check SetColor To learn about
; color values.
Declare SetFillStyle(pattern.l, color.l)
; Sets the mode in witch flood-fills are performed With FloodFill routine. Argument (floodmode) has the following pre-defined
; values:
; BorderFlood - the fill area is bounded by the color specified in FloodFill filling begins at the specified point and continues
; in all directions Until it reaches the color bounding the area this is the default.
; SurfaceFlood - the fill area is defined by the color that is specified in FloodFill filling begins at the specified point and
; continues in all directions over all adjacent regions containing the specified color this mode is useful for
; filling areas With multicolored boundaries
; See also FloodFill routine.
Declare SetFloodMode(floodmode.l)
; text And font handling exported routines
; Retrieves some information about the current selected font. First argument contains the full registered name of the font
; (ex. "Courier New"). It is the same name used by routine InstallUserFont when the font was installed. Variables (width) And
; (height) contain the maximum dimensions of the characters in the font. If you want To retrive the dimensions of specific
; characters use TextWidth And TextHeight routines. Boolean argument (ttfont) specify If the technology of this font is a
; TrueType one. If so, the text can be rotated on screen using SetTextStyle routine. Otherwise, it cannot be rotated.
Declare GetFontSettings(fontname.s, *width.integer, *height.integer, *ttfont.integer) ; BOOLEAN
; Returns the current font And text settings in argument (textinfo). This contains the font type, direction, magnification,
; horizontal And vertical alignment, As set by SetTextStyle And SetTextJustify routines.
Declare GetTextSettings(*textinfo.TextSettingsType)
; Installs a new font And returns its index into the installed font table. This index can be used With SetTextStyle To enable
; the font For texts. The parameter (fontname) must be a valid family font name registered into the system (ex: " Fixedsys").
; The name IS Case sensitive. If the font cannot be registered, InstallUserFont will Return -1.
; InitGraph installs several fonts using this routine. Default font is set To "Courier New". Other installed fonts are listed in
; section Font constants For text. For more info about fonts see SetTextStyle.
Declare.i InstallUserFont(fontname.s)
; Puts (textstring) on the screen, at the current pointer position, using the current font And text settings. The current
; position is moved To the End of the text. Use SetTextStyle To change font style And SetTextJustify To change text alignment.
; To put text on an absolute location use OutTextXY instead.
Declare OutText(textstring.s, color.l = -1, bcol.l = -1)
; Puts (textstring) on the screen, at the coordinates (x,y), using the current font And text settings. The current position is
; moved To the End of the text. See OutText For more details.
Declare OutTextXY(x.l, y.l, textstring.s, color.l = -1, bcol.l = -1)
; It controls the placement of new text, relative To the cursor position. Argument (horiz) controls horizontal placement, And
; can be one of the following pre-defined constants:
; LeftText - text is set left of the pointer
; CenterText - text is set centered horizontally on the pointer
; RightText - text is set To the right of the pointer
; Argument (vert) controls the vertical placement of the text. Its value can be one of the following pre-defined constants:
; TopText - text is placed above the pointer
; BottomText - text is placed under the pointer
; BaselineText - text is placed relative To its base line
; Default text placement is LeftText And TopText.
Declare SetTextJustify(horiz.i,vert.i)
; It controls the style of text To be put on the screen. Pre-defined constants For (font) are:
; CourierNewFont - Courier New font
; MSSansSerifFont - MS Sans Serif font
; TimesNewRomanFont - Times New Roman font
; ArialFont - Arial font
; DefaultFont=CourierNewFont
; Besides, any successfully installed user font can be used insted. See InstallUserFont For details. All these fonts can be Or-ed
; With the following additional styles To change their appearance:
; ItalicFont - italic font
; UnderlineFont - underlined font
; BoldFont - bold font
; Argument (direction) sets the direction of text. It can be any positive value in degrees Or one of the following constants:
; HorizDir = 0
; VertDir = 90
; Between 1 And 5, (charsize) represents the magnification of the characters With a standard font size of 8 pixels. Above 6 it
; represents an absolute font size. Default is set To 16.
; Be aware that some fonts (including pre-defined) do Not support all these styles. See GetFontSettings routine For more details.
; Use SetColor To set text color.
Declare SetTextStyle(font.i,direction.i,charsize.i)
; First argument (nCharExtra) sets the intercharacter spacing in text And the second one (nBreakExtra) sets the amount of space
; reserved For Break character. The other ones are dummy arguments (Not used). This is a major incompatibility With BP graph unit.
; Default values are zero.
; See SetTextStyle For other text styles.
Declare SetUserCharSize(nCharExtra.i,nBreakExtra.i,dummy1.i,dummy2.i)
; Returns the height (in pixels) of the (textstring) in the current font style. This value might be altered by a call To
; SetTextStyle Or SetUserCharSize.
Declare.i TextHeights(textstring.s)
; Returns the width (in pixels) of the (textstring) in the current font style. This value might be altered by a call To
; SetTextStyle Or SetUserCharSize.
Declare.i TextWidths(textstring.s)
Declare THREEDto2DAll(*coords.ThreeDPointType, *pan.ThreeDPointType, *centre.ThreeDPointType, *position.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Declare THREEDto2D(*coords.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Declare DrawSymbol(x.l, y.l, color.l, symbol.l, width.l, height.l)
; caret format: block Or underline
Global CaretBlock.i = 1
; caret blink rate in tenths OF a second
Global BlinkRate.i = 2
Declare DrawCaret(nr.i)
Declare TextSettings()
EndDeclareModule
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Module MINIBGI
EnableExplicit
#NrVideoPages = 4; ;number OF available video pages
#Rad = #PI/180.0
#NrMaxFonts = 15
#MinCharSize = 8
#NrColorNames = 256
Global screenWidth.i,screenHeight.i, hwnd.i
Global Dim interncolor.l(#NrColorNames-1)
Global customWidth.i,customHeight.i
Global windowWidth.i,windowHeight.i
Global windowStyle.l, grHandle.l
Global grTitle.s = "NONAME"
Global maxX.l,maxY.l,origX.l,origY.l, actX.l,actY.l,aspX.l,aspY.l
Global defAspectRatio.i, old_Palette.i
Global grWindow.l
Global grPen.l,old_Pen.l
Global grBrush.l,old_Brush.l
Global grFont.l,old_Font.l
Global grPattern.l,old_Bitmap.l
Global Dim grBitmap.i(#NrVideoPages-1)
Global Dim instFont.s(#NrMaxFonts-1)
Global frcolor.l,bkcolor.l,grClip.l
Global lineSettings.LineSettingsType
Global fillSettings.FillSettingsType
Global textSettings.TextSettingsType
Global Dim fillPattern.b(8)
Global viewPort.ViewPortType
Global lastArcCoords.ArcCoordsType
Global viewPortWidth.l,viewPortHeight.l
Global floodMode.l, globalTemp.l
Procedure.b LOBYTE(w.w)
ProcedureReturn w & $0FF
EndProcedure
Procedure.b HIBYTE(w.w)
ProcedureReturn (w >> 8) & $0FF
EndProcedure
Procedure.w LOWORD(l.l)
ProcedureReturn l & $0FFFF
EndProcedure
Procedure.w HIWORD(l.l)
ProcedureReturn (l >> 16) & $0FFFF
EndProcedure
Procedure.i EnumFontFamProc(*lpelf.LOGFONT, *lpntm.NEWTEXTMETRIC, FontType.l, param.i) ;:LPARAM
globalTemp = 1 ; we got here IF at least one font from the family font exists
ProcedureReturn 0
EndProcedure
#NrDefFonts = 4
Procedure InstallDefaultFonts()
Protected Dim DefaultFont.s(#NrDefFonts-1)
Protected i.i
DefaultFont.s(0) = "Courier New"
DefaultFont.s(1) = "MS Sans Serif"
DefaultFont.s(2) = "Times New Roman"
DefaultFont.s(3) = "Arial"
For i = 0 To #NrMaxFonts-1
instFont(i) = ""
Next
For i=0 To #NrDefFonts-1
InstallUserFont(DefaultFont(i))
Next
EndProcedure
Procedure LineProc(x.l,y.l, param.l) ;:LPARAM)
param = param >> globalTemp
If (param & $0001 <> 0)
PutPixel(x,y,frcolor)
EndIf
globalTemp = (globalTemp+1) % 16
EndProcedure
Procedure SetAttrib_BGI()
Protected.i dx_bor,dy_bor,dx,dy,tmp
dx_bor = 2*GetSystemMetrics_(#SM_CXFIXEDFRAME)
dy_bor = 2*GetSystemMetrics_(#SM_CYFIXEDFRAME)+GetSystemMetrics_(#SM_CYCAPTION)
dx = customWidth
dy = customHeight
windowWidth = dx + dx_bor
windowHeight = dy + dy_bor
If (windowWidth <= screenWidth) And (windowHeight <= screenHeight)
windowStyle = #WS_OVERLAPPED | #WS_SYSMENU | #WS_CAPTION | #WS_MINIMIZEBOX
Else
If (dx <= screenWidth) And (dy <= screenHeight)
windowWidth = dx
windowHeight = dy
windowStyle = #WS_POPUP
Else
ProcedureReturn
EndIf
EndIf
EndProcedure
;initialization routines
Procedure CloseGraph()
Protected exitcode.i, i.i
DeleteObject_(grPattern)
For i=0 To #NrVideoPages-1
DeleteObject_(grBitmap(i))
Next
SelectObject_(grWindow,old_Font)
DeleteObject_(grFont)
SelectObject_(grWindow,old_Brush)
DeleteObject_(grBrush)
SelectObject_(grWindow,old_Pen)
DeleteObject_(grPen)
SetViewPort(0,0,maxX,maxY,#ClipOff)
DeleteDC_(grWindow)
EndProcedure
Procedure.i GetDC()
ProcedureReturn grWindow
EndProcedure
Procedure.i InitGraph(windownumber.i, WinX.l, WinY.l, title.s) ;<- main entry point*)
Protected grRect.RECT
Protected.i dx_bor,dy_bor,dx,dy,tmp
Protected *pbmi.BITMAPINFO
Protected pbits.l = #Null ;LPVOID
Protected i.i,nr.i = 0
Protected Dim pattern.b(8) ; FillPatternType
grHandle = WindowID(windownumber)
hwnd = windownumber
GetClientRect_(grHandle, grRect)
maxX = grRect\right-1
maxY = grRect\bottom-1
grWindow = GetDC_(grHandle)
old_Palette= GetCurrentObject_(grWindow,#OBJ_PAL)
old_Pen = GetCurrentObject_(grWindow,#OBJ_PEN)
old_Brush = GetCurrentObject_(grWindow,#OBJ_BRUSH)
old_Font = GetCurrentObject_(grWindow,#OBJ_FONT)
InstallDefaultFonts()
lineSettings\linestyle = #SolidLn
lineSettings\pattern = 0
lineSettings\thickness = #NormWidth
SetColor(#_Black)
SetBkColor(#_White)
FillMemory(@pattern(0), 8, $FF)
SetFillPattern(pattern(),#_White)
SetFillStyle(#SolidFill,#_White)
SetTextStyle(#DefaultFont,#HorizDir,16)
SetTextJustify(#LeftText,#TopText)
SetUserCharSize(0,0,0,0)
SetViewPort(0,0,maxX,maxY,#ClipOff)
SetWriteMode(#CopyMode | #TRANSPARENT)
defAspectRatio = SetAspectRatio(10000,10000)
floodMode = #BorderFlood
If title <> ""
grTitle = title
EndIf
SetWindowTitle(windownumber, grTitle)
ShowWindow_(grHandle,#SW_SHOWNORMAL)
SetViewPort(0, 0, maxX, maxY, #ClipOff)
ClearViewPort()
SetForegroundWindow_(grHandle)
ProcedureReturn windownumber
EndProcedure
Procedure SetWindowSize(width.l,height.l)
customWidth = width
customHeight = height
EndProcedure
; screen management routines
Procedure ClearDevice()
Protected old_ViewPort.ViewPortType
old_ViewPort = viewPort
SetViewPort(0, 0, maxX, maxY, #ClipOff)
ClearViewPort()
With old_ViewPort
SetViewPort(\x1,\y1,\x2,\y2, \clip)
EndWith
EndProcedure
Procedure ClearDeviceWithColor(color.l)
Protected.l bcol = GetBkColor()
SetBkColor(color)
ClearDevice()
SetBkColor(bcol)
EndProcedure
Procedure ClearViewPortWithColor(color.l)
Protected.l bcol = GetBkColor()
SetBkColor(color)
ClearViewPort()
SetBkColor(bcol)
EndProcedure
Procedure ClearViewPort()
Protected old_FillSettings.FillSettingsType
MoveTo(0,0)
old_FillSettings = fillSettings
SetFillStyle(#SolidFill, bkcolor)
Bar(0,0,viewPortWidth,viewPortHeight)
With old_FillSettings
SetFillStyle(\pattern, \color)
EndWith
EndProcedure
Procedure GetAspectRatio(*xasp.integer,*yasp.integer)
*xasp = aspX
*yasp = aspY
EndProcedure
Procedure.i GetMaxX()
ProcedureReturn maxX
EndProcedure
Procedure.i GetMaxY()
ProcedureReturn maxY
EndProcedure
Procedure GetViewSettings(*tviewport.ViewPortType)
*tviewport = viewPort
EndProcedure
Procedure.i GetXX()
ProcedureReturn actX
EndProcedure
Procedure.i GetYY()
ProcedureReturn actY
EndProcedure
Procedure SetAspectRatio(xasp.i,yasp.i)
aspX = xasp
aspY = yasp
defAspectRatio = Bool(Bool(xasp = 10000) And Bool(yasp = 10000))
EndProcedure
Procedure SetViewPort(x1.l,y1.l,x2.l,y2.l, clip.l) ;BOOLEAN
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
viewPort\x1 = x1
viewPort\y1 = y1
viewPort\x2 = x2
viewPort\y2 = y2
viewPort\clip = clip
viewPortWidth = x2-x1
viewPortHeight = y2-y1
origX = x1
origY = y1
MoveTo(0,0)
If grClip <> #Null
SelectClipRgn_(grWindow,#Null)
DeleteObject_(grClip)
grClip = #Null
EndIf
If clip <> 0
grClip = CreateRectRgn_(x1,y1,x2+1,y2+1)
SelectClipRgn_(grWindow, grClip)
EndIf
EndProcedure
Procedure SetWriteMode(writemode.l)
Protected.l fnDrawMode,iBkMode
fnDrawMode = writemode % $10
iBkMode = (writemode / $10) << 4
Select fnDrawMode
Case #CopyMode : fnDrawMode = #R2_COPYPEN
Case #XorMode : fnDrawMode = #R2_XORPEN
Case #OrMode : fnDrawMode = #R2_MERGEPEN
Case #AndMode : fnDrawMode = #R2_MASKPEN
Case #NotMode : fnDrawMode = #R2_NOTCOPYPEN
Case #NotScrMode : fnDrawMode = #R2_NOT
Case #NotXorMode : fnDrawMode = #R2_NOTXORPEN
Case #NotOrMode : fnDrawMode = #R2_NOTMERGEPEN
Case #NotAndMode : fnDrawMode = #R2_NOTMASKPEN
Case #InvColAndMode: fnDrawMode = #R2_MASKNOTPEN
Case #InvColOrMode : fnDrawMode = #R2_MERGENOTPEN
Case #InvScrAndMode: fnDrawMode = #R2_MASKPENNOT
Case #InvScrOrMode : fnDrawMode = #R2_MERGEPENNOT
Case #BlackMode : fnDrawMode = #R2_BLACK
Case #WhiteMode : fnDrawMode = #R2_WHITE
Case #EmptyMode : fnDrawMode = #R2_NOP
Default
ProcedureReturn
EndSelect
Select iBkMode
Case #TRANSPARENT_: iBkMode = #TRANSPARENT
Case #OPAQUE_ : iBkMode = #OPAQUE
Default
ProcedureReturn
EndSelect
SetROP2_(grWindow,fnDrawMode)
SetBkMode_(grWindow,iBkMode)
EndProcedure
; color management routines
Procedure.l GetBkColor()
ProcedureReturn bkcolor
EndProcedure
Procedure.l GetColor()
ProcedureReturn frcolor
EndProcedure
Procedure.l GetMaxColor()
ProcedureReturn $0FFFFFF
EndProcedure
Procedure.l GetPixel(x.l,y.l)
Protected Result.i
Result = GetPixel_(grWindow,x+origX,y+origY)
ProcedureReturn Result
EndProcedure
Procedure GetRGBComponents(color.l, *r.long,*g.long,*b.long, *t.long=#Null)
Protected pe.PALETTEENTRY
*r = Red(color)
*g = Green(color)
*b = Blue(color)
EndProcedure
Procedure SetBkColor(color.l)
bkcolor = color
SetBkColor_(grWindow, color)
EndProcedure
Procedure SetColor(color.l)
frcolor = color
SetTextColor_(grWindow, color)
SetLineStyle(lineSettings\linestyle, lineSettings\pattern, lineSettings\thickness)
EndProcedure
; drawing primitives routines
Procedure Arc(x.l,y.l, start.l,stop.l,radius.l)
Ellipses(x,y,start,stop,radius,radius)
EndProcedure
Procedure Circles(x.l,y.l, radius.l)
Ellipses(x,y,0,360,radius,radius)
EndProcedure
Procedure DrawBezier(nrpoints.i, Array *polypoints.PointType(1))
Protected.i size,i
If nrpoints >= 4
PolyBezier_(grWindow, *polypoints(0), nrpoints)
EndIf
EndProcedure
Procedure DrawPoly(nrpoints.i, Array *polypoints.PointType(1))
Protected.i size,i
If nrpoints < 2
ProcedureReturn
EndIf
Polyline_(grWindow,*polypoints(0),nrpoints)
EndProcedure
Procedure Ellipses(x.l, y.l, start.l,stop.l,xradius.l,yradius.l)
Protected.i nXStartArc,nYStartArc,nXEndArc,nYEndArc
lastArcCoords\x = x;
lastArcCoords\y = y
INC(x,origX)
INC(y,origY)
nXStartArc = Round(xradius * Cos(start*#Rad), #PB_Round_Nearest)
nXEndArc = Round(xradius * Cos(stop*#Rad), #PB_Round_Nearest)
nYStartArc = Round(yradius * Sin(start*#Rad), #PB_Round_Nearest)
nYEndArc = Round(yradius * Sin(stop*#Rad), #PB_Round_Nearest)
If defAspectRatio = 0
xradius = Int(10000*xradius) / aspX;
yradius = Int(10000*yradius) / aspY
EndIf
Arc_(grWindow,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1,x+nXStartArc,y-nYStartArc,x+nXEndArc,y-nYEndArc)
With lastArcCoords
\xstart = \x+nXStartArc
\ystart = \y-nYStartArc
\xend = \x+nXEndArc
\yend = \y-nYEndArc
EndWith
EndProcedure
Procedure GetArcCoords(*arccoords.ArcCoordsType)
*arccoords = lastArcCoords
EndProcedure
Procedure GetLineSettings(*lineinfo.LineSettingsType)
*lineinfo = lineSettings
EndProcedure
Procedure Lines(x1.l,y1.l,x2.l,y2.l)
MoveTo(x1,y1)
LineTo(x2,y2)
EndProcedure
Procedure LineRel(dx.l,dy.l)
LineTo(actX+dx,actY+dy)
EndProcedure
Procedure LineTo(x.l,y.l)
Protected.i x0,y0
x0 = x
y0 = y
INC(x, origX)
INC(y, origY)
With lineSettings
If \linestyle <> #UserBitLn
LineTo_(grWindow,x,y)
If \thickness = #NormWidth
PutPixel(x0,y0,frColor)
EndIf
EndIf
MoveTo(x0,y0)
EndWith
EndProcedure
Procedure MoveRel(dx.l,dy.l)
INC(actX, dx)
INC(actY, dy)
MoveTo(actX,actY)
EndProcedure
Procedure MoveTo(x.l,y.l)
Protected d.POINT
actX = x;
actY = y
INC(x, origX)
INC(y, origY)
MoveToEx_(grWindow,x,y,d)
EndProcedure
Procedure PutPixel(x.l,y.l, color.l)
INC(x, origX)
INC(y, origY)
SetPixelV_(grWindow,x,y,color)
EndProcedure
Procedure Rectangle(x1.l,y1.l,x2.l,y2.l)
Protected Dim pt.POINT(5)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
If (x1 <> x2) Or (y1 <> y2)
pt(1)\x = x1: pt(1)\y = y1
pt(2)\x = x2: pt(2)\y = y1
pt(3)\x = x2: pt(3)\y = y2
pt(4)\x = x1: pt(4)\y = y2
pt(5)\x = x1: pt(5)\y = y1
Polyline_(grWindow, @pt(0),5)
Else
PutPixel(x1,y1,frcolor)
EndIf
EndProcedure
Procedure RotEllipse(x.l,y.l,rot.i, xradius.i,yradius.i)
Protected Dim pt.PointType(7)
Protected.d cosrot,sinrot
Protected.i x1,y1,i
xradius = Round(1.3333*xradius, #PB_Round_Nearest)
cosrot = Cos(rot*#Rad): sinrot = Sin(rot*#Rad)
pt(1)\x = 0: pt(1)\y = -Int(yradius)
pt(2)\x = xradius: pt(2)\y = -Int(yradius)
pt(3)\x = xradius: pt(3)\y = (yradius)
pt(4)\x = 0: pt(4)\y = (yradius)
pt(5)\x = -Int(xradius): pt(5)\y = (yradius)
pt(6)\x = -Int(xradius): pt(6)\y = -Int(yradius)
pt(7)\x = 0: pt(7)\y = -Int(yradius)
For i = 1 To 7
x1 = pt(i)\x: y1 = pt(i)\y ; perform rotation
pt(i)\x = x+Round( x1*cosrot+y1*sinrot, #PB_Round_Nearest)
pt(i)\y = y+Round(-x1*sinrot+y1*cosrot, #PB_Round_Nearest)
Next
DrawBezier(7, pt())
EndProcedure
Procedure SetLineStyle(linestyle.i,pattern.l,thickness.i)
Protected lgpn.LOGPEN
Protected old.l ;HGDIOBJ
Protected lstyle.l
DeleteObject_(grPen)
;ReleaseDC_(grHandle, grWindow)
grWindow = GetDC_(grHandle)
Select linestyle
Case #SolidLn : lstyle = #PS_SOLID
Case #DashedLn : lstyle = #PS_DASH
Case #DottedLn : lstyle = #PS_DOT
Case #DashDotLn : lstyle = #PS_DASHDOT
Case #DashDotDotLn : lstyle = #PS_DASHDOTDOT
Case #UserBitLn,#NullLn: lstyle = #PS_NULL
Default
ProcedureReturn
EndSelect
lineSettings\linestyle = linestyle
lineSettings\pattern = pattern
lineSettings\thickness = thickness
lgpn\lopnStyle = lstyle
lgpn\lopnWidth\x = thickness
lgpn\lopnColor = frcolor
grPen = CreatePenIndirect_(lgpn)
SelectObject_(grWindow, grPen)
EndProcedure
;filled drawings routines
Procedure Bar(x1.l,y1.l,x2.l,y2.l)
Protected rc.RECT
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
SetRect_(@rc,x1,y1,x2+1,y2+1)
FillRect_(grWindow,@rc,grBrush)
EndProcedure
Procedure Bar3D(x1.l,y1.l,x2.l,y2.l, depth.l, top.l, col.l) ;:BOOLEAN)
Protected Dim pt.POINT(4)
FillRect(x1,y1,x2,y2, col);
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
If top <> 0
pt(1)\x = x1: pt(1)\y = y1
pt(2)\x = x1+Int(depth): pt(2)\y = y1-Int(depth)
pt(3)\x = x2+Int(depth): pt(3)\y = y1-Int(depth)
pt(4)\x = x2: pt(4)\y = y1
Polyline_(grWindow,@pt(),4)
EndIf
If depth <> 0
pt(1)\x = x2+Int(depth): pt(1)\y = y1-Int(depth)
pt(2)\x = x2+Int(depth): pt(2)\y = y2-Int(depth)
pt(3)\x = x2: pt(3)\y = y2
Polyline_(grWindow,@pt(),3)
EndIf
EndProcedure
Procedure Chord(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
Protected.i nXRadial1,nYRadial1,nXRadial2,nYRadial2
INC(x, origX)
INC(y, origY)
nXRadial1 = Round(xradius*Cos(start*#Rad), #PB_Round_Nearest): nXRadial2 = Round(xradius*Cos(stop*#Rad), #PB_Round_Nearest)
nYRadial1 = Round(yradius*Sin(start*#Rad), #PB_Round_Nearest): nYRadial2 = Round(yradius*Sin(stop*#Rad), #PB_Round_Nearest)
If defAspectRatio = 0
xradius = 10000*Int(xradius) / aspX: yradius = 10000*Int(yradius) / aspY
EndIf
Chord_(grWindow,x-xradius,y-yradius,x+xradius+1,y+yradius+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2)
EndProcedure
Procedure FillEllipse(x.l,y.l,xradius.i,yradius.i, col.l)
Protected fillinfo.FillSettingsType
INC(x, origX)
INC(y, origY)
If defAspectRatio <> 0
xradius = Int(10000*xradius) / aspX;
yradius = Int(10000*yradius) / aspY
EndIf
GetFillSettings(@fillinfo)
SetFillStyle(#SolidFill, col)
Ellipse_(grWindow,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1)
SetFillStyle(fillinfo\pattern, fillinfo\color)
EndProcedure
Procedure FillPoly(nrpoints.i, Array *polypoints.PointType(1))
Protected.i size,i
If nrpoints >= 2
SetPolyFillMode_(grWindow, 2)
Polygon_(grWindow, *polypoints(), nrpoints)
EndIf
EndProcedure
Procedure FillRect(x1.l,y1.l,x2.l,y2.l, col.l)
Protected fillinfo.FillSettingsType
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX+1)
INC(y2, origY+1)
GetFillSettings(@fillinfo)
SetFillStyle(#SolidFill, col)
Rectangle_(grWindow,x1,y1,x2,y2)
SetFillStyle(fillinfo\pattern, fillinfo\color)
EndProcedure
Procedure FloodFill(x.l,y.l, color.l)
INC(x, origX)
INC(y, origY)
ExtFloodFill_(grWindow,x,y,color,floodMode)
EndProcedure
Procedure GetFillPattern(Array *fillpatternn.byte(1))
CopyArray(*fillPatternn(), fillpattern())
EndProcedure
Procedure GetFillSettings(*fillinfo.FillSettingsType)
*fillinfo = fillSettings
EndProcedure
Procedure InvertRect(x1.l,y1.l,x2.l,y2.l)
Protected rc.RECT
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
SetRect_(@rc,x1,y1,x2+1,y2+1)
InvertRect_(grWindow, @rc)
EndProcedure
Procedure PieSlice(x.l,y.l, start.i,stop.i,radius.l)
Sector(x,y,start,stop,radius,radius)
EndProcedure
Procedure RoundRect(x1.l,y1.l,x2.l,y2.l,r.l)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
INC(x1, origX)
INC(y1, origY)
INC(x2, origX)
INC(y2, origY)
RoundRect_(grWindow,x1,y1,x2+1,y2+1,r,r)
EndProcedure
Procedure Sector(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
Protected.i nXRadial1,nYRadial1,nXRadial2,nYRadial2
INC(x, origX)
INC(y, origY)
nXRadial1 = Round(xradius*Cos(start*#Rad), #PB_Round_Nearest)
nXRadial2 = Round(xradius*Cos(stop*#Rad), #PB_Round_Nearest)
nYRadial1 = Round(yradius*Sin(start*#Rad), #PB_Round_Nearest)
nYRadial2 = Round(yradius*Sin(stop*#Rad), #PB_Round_Nearest)
If defAspectRatio <> 0
xradius = Int(10000*xradius) / aspX : yradius = Int(10000*yradius) / aspY
EndIf
Pie_(grWindow,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2)
EndProcedure
Procedure SetFillPattern(Array fillpattern.b(1), color.l)
Protected.i i,j
Protected.i col0,col1 ; COLORREF
Protected.b b
CopyArray(fillpattern(), fillPattern())
col1 = color
col0 = bkcolor
If grPattern <> #Null
DeleteObject_(grPattern)
EndIf
grPattern = CreateCompatibleBitmap_(grWindow,8,8)
SelectObject_(grWindow, grPattern)
For i = 0 To 7
b = fillpattern(i+1)
For j = 7 To 0 Step -1
If (b & $01) <> 0
SetPixelV_(grWindow,j,i,col1)
Else
SetPixelV_(grWindow,j,i,col0)
EndIf
b = b >> 1
Next
Next
SelectObject_(grWindow,old_Bitmap)
SetFillStyle(#UserFill, color)
EndProcedure
Procedure SetFillStyle(pattern.l, color.l)
Protected lplb.LOGBRUSH
lplb\lbStyle = #BS_HATCHED
lplb\lbHatch = 0
Select pattern
Case #SolidFill : lplb\lbStyle = #BS_SOLID
Case #EmptyFill : lplb\lbStyle = #BS_SOLID :
color = bkcolor
Case #LineFill : lplb\lbHatch = #HS_HORIZONTAL
Case #ColFill : lplb\lbHatch = #HS_VERTICAL
Case #HatchFill : lplb\lbHatch = #HS_CROSS
Case #SlashFill : lplb\lbHatch = #HS_BDIAGONAL
Case #BkSlashFill: lplb\lbHatch = #HS_FDIAGONAL
Case #XHatchFill : lplb\lbHatch = #HS_DIAGCROSS
Case #UserFill : lplb\lbStyle = #BS_PATTERN :
lplb\lbHatch = grPattern
Case #NoFill : lplb\lbStyle = #BS_NULL
Default
ProcedureReturn
EndSelect
lplb\lbColor = color
fillSettings\pattern = pattern
fillSettings\color = color
DeleteObject_(grBrush)
grBrush = CreateBrushIndirect_(@lplb)
SelectObject_(grWindow, grBrush)
EndProcedure
Procedure SetFloodMode(floodmode.l)
Select floodmode
Case #BorderFlood : floodMode = #FLOODFILLBORDER
Case #SurfaceFlood: floodMode = #FLOODFILLSURFACE
EndSelect
EndProcedure
;text And font handling routines
Procedure GetFontSettings(fontname.s, *width.integer, *height.integer, *ttfont.integer)
Protected *lptm.TEXTMETRIC
Protected len.i
Protected x.s = Space(255), tt.s = ""
len = GetTextFace_(grWindow,255, @x)
tt = Chr(len-1) + Space(255)
GetTextFace_(grWindow,255, @tt)
GetTextMetrics_(grWindow, *lptm)
With *lptm
*width = \tmMaxCharWidth
*height = \tmHeight
*ttfont = Bool((\tmPitchAndFamily & #TMPF_TRUETYPE) <> 0)
EndWith
EndProcedure
Procedure GetTextSettings(*textinfo.TextSettingsType)
*textinfo = textSettings
EndProcedure
Procedure.i InstallUserFont(fontname.s)
Protected.i i, Result=-1
Protected famName.s = ""
famName = fontname
globalTemp = 0
EnumFontFamilies_(grWindow,@famName,@EnumFontFamProc(),0)
If globalTemp = 1
For i = 0 To #NrMaxFonts-1
If instFont(i) = ""
instFont(i) = fontname; ;+0H;*)
Result = i
Break
EndIf
Next
EndIf
ProcedureReturn Result
EndProcedure
Procedure OutText(textstring.s, color.l = -1, bcol.l = -1)
Protected backcoltmp.l = GetBkColor()
If color = -1
SetTextColor_(grWindow, frcolor)
Else
SetTextColor_(grWindow, color)
EndIf
If bcol = -1
SetBkColor_(grWindow, bkcolor)
Else
SetBkColor_(grWindow, bcol)
EndIf
MoveTo(actX, actY)
TextOut_(grWindow,actX,actY,@textstring,Len(textstring))
If bcol <> -1
SetBkColor_(grWindow, backcoltmp)
EndIf
EndProcedure
Procedure OutTextXY(x.l, y.l, textstring.s, color.l = -1, bcol.l = -1)
Protected backcoltmp.l = GetBkColor()
Protected tttt.i
If color = -1
SetTextColor_(grWindow, frcolor)
Else
SetTextColor_(grWindow, color)
EndIf
If bcol = -1
SetBkColor_(grWindow, bkcolor)
Else
SetBkColor_(grWindow, bcol)
EndIf
MoveTo(x, y)
TextOut_(grWindow, 0, 0, @textstring, Len(textstring))
If bcol <> -1
SetBkColor_(grWindow, backcoltmp)
EndIf
EndProcedure
Procedure SetTextJustify(horiz.i, vert.i)
Protected.i htext,vtext
Select horiz
Case #LeftText : htext = #TA_LEFT
Case #CenterText: htext = #TA_CENTER
Case #RightText : htext = #TA_RIGHT
Default
ProcedureReturn
EndSelect
Select vert
Case #TopText : vtext = #TA_TOP
Case #BottomText : vtext = #TA_BOTTOM
Case #BaselineText: vtext = #TA_BASELINE
Default
ProcedureReturn
EndSelect
textSettings\horiz = horiz
textSettings\vert = vert
SetTextAlign_(grWindow,htext | vtext | #TA_UPDATECP)
EndProcedure
Procedure SetTextStyle(font.i,direction.i,charsize.i)
Protected.b loByte,hiByte
Protected.b nrfont
Protected fontname.s = ""
Protected lplf.LOGFONT
Protected old.i ;HGDIOBJ
loByte = LOBYTE(LOWORD(font))
hiByte = HIBYTE(HIWORD(font))
nrfont = loByte % $10
If (nrfont>=0) And (nrfont <= #NrMaxFonts-1)
fontname = instFont(nrfont)
Else
fontname = ""
EndIf
If fontname <> ""
textSettings\font = font
textSettings\direction = direction
textSettings\charsize = charsize
If charsize <= 5
charsize = charsize * #MinCharSize
EndIf
lplf\lfHeight = charsize
lplf\lfWidth = 0
lplf\lfEscapement = 10 * direction
lplf\lfOrientation = 10 * direction
lplf\lfItalic = #False
lplf\lfWeight = (#FW_BOLD - #FW_NORMAL) * (loByte / $10) + #FW_NORMAL
If (hiByte / $10) > 0
lplf\lfItalic = 1
EndIf
lplf\lfUnderline = 0
If (hiByte / $10) > 0
lplf\lfUnderline = 1
EndIf
lplf\lfStrikeOut = 0
lplf\lfCharSet = #DEFAULT_CHARSET
lplf\lfOutPrecision = #OUT_DEFAULT_PRECIS
lplf\lfClipPrecision = #CLIP_DEFAULT_PRECIS
lplf\lfQuality = #DEFAULT_QUALITY
lplf\lfPitchAndFamily = #DEFAULT_PITCH | #FF_DONTCARE
PokeS(@lplf\lfFaceName[0], fontname)
grFont = CreateFontIndirect_(lplf)
SelectObject_(grWindow, grFont)
EndIf
EndProcedure
Procedure SetUserCharSize(nCharExtra.i,nBreakExtra.i,dummy1.i,dummy2.i)
SetTextCharacterExtra_(grWindow,nCharExtra)
SetTextJustification_(grWindow,nBreakExtra,1)
EndProcedure
Procedure.i TextHeights(textstring.s)
Protected lpSize.SIZE
Protected len.i
len = Len(textstring)
GetTextExtentPoint32_(grWindow,@textstring,len, @lpSize)
ProcedureReturn lpSize\cy
EndProcedure
Procedure.i TextWidths(textstring.s)
Protected lpSize.SIZE
Protected len.i
len = Len(textstring)
GetTextExtentPoint32_(grWindow,@textstring,len, @lpSize)
ProcedureReturn lpSize\cx
EndProcedure
Procedure THREEDto2DAll(*coords.ThreeDPointType, *pan.ThreeDPointType, *centre.ThreeDPointType, *position.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Protected new.ThreeDPointType
INC(*coords\x, *position\x)
INC(*coords\y, *position\y)
INC(*coords\z, *position\z)
new\x = *coords\x*Cos(*pan\x) - *coords\z*Sin(*pan\x)
new\z = *coords\x*Sin(*pan\x) + *coords\z*Cos(*pan\x)
new\y = *coords\y*Cos(*pan\y) - new\z*Sin(*pan\y)
*coords\z = new\y*Cos(*pan\y) - new\z*Sin(*pan\y)
*coords\x = new\x*Cos(*pan\z) - new\y*Sin(*pan\z)
*coords\y = new\x*Sin(*pan\z) + new\y*Cos(*pan\z)
If *coords\z > 0.0
*sx = *coords\x / *coords\z * zoom + *centre\x
*sy = *coords\y / *coords\z * zoom + *centre\y
Else
*sx = *coords\x * zoom + *centre\x
*sy = *coords\y * zoom + *centre\y
EndIf
EndProcedure
Procedure THREEDto2D(*coords.ThreeDPointType, zoom.d, *sx.double, *sy.double)
*sx = *coords\x / *coords\z * zoom
*sy = *coords\y / *coords\z * zoom
EndProcedure
Procedure DrawSymbol(x.l, y.l, color.l, symbol.l, width.l, height.l)
Protected currfcol.l = GetColor()
SetColor(color)
Select symbol
Case #SYMBOLRECTANGLE:
lines(x - width/2, y - height/2, x + width/2, y - height/2)
lines(x + width/2, y - height/2, x + width/2, y + height/2)
lines(x + width/2, y + height/2, x - width/2, y + height/2)
lines(x - width/2, y + height/2, x - width/2, y - height/2)
Case #SYMBOLTRIANGLE:
lines(x - width/2, y + height/2, x, y - height/2)
lines(x, y - height/2, x + width/2, y + height/2)
lines(x + width/2, y + height/2, x - width/2, y + height/2)
Case #SYMBOLDIAMOND:
lines(x - width/2, y, x, y - height/2)
lines(x, y - height/2, x + width/2, y)
lines(x + width/2, y, x, y + height/2)
lines(x, y + height/2, x - width/2, y)
Case #SYMBOLCROSS:
lines(x - width/2, y, x + width/2, y)
lines(x, y - height/2, x, y + height/2)
Case #SYMBOLXCROSS:
lines(x - width/2, y + height/2, x + width/2, y - height/2)
lines(x - width/2, y - height/2, x + width/2, y + height/2)
Default
EndSelect
SetColor(currfcol)
EndProcedure
Global old_TextSettings.TextSettingsType
Global.i textX,textY,textW,textH
Procedure DrawCaret(nr.i)
Select nr
Case 0: SetFillStyle(#SolidFill,GetBkColor())
Case 1: SetFillStyle(#SolidFill,GetColor())
EndSelect
If (CaretBlock <> 0) Or (nr = 0)
Bar(textX,textY,textX+textW,textY+textH)
Else
Bar(textX,textY+textH-1,textX+textW,textY+textH)
EndIf
EndProcedure
Procedure TextSettings()
Protected viewport.ViewPortType
With old_TextSettings
SetTextStyle(#DefaultFont | (\font / $10) << 4,0, \charsize) ; keep font format
SetTextJustify(#LeftText, #TopText)
EndWith
textX = GetX()
textY = GetY()
textW = TextWidths("W")
textH = TextHeights("H")
GetViewSettings(viewport)
With viewport
maxX = \x2-\x1
maxY = \y2-\y1
EndWith
EndProcedure
EndModule
Last edited by startup on Mon Sep 21, 2015 4:58 pm, edited 1 time in total.