'View RGB
'作者：zyl910
'使用有序抖动算法（dither）绘制线性渐变区域、RGB色彩空间（Screen 12下）
' Up , Down , PageUp , PageDown: 改变B分量
' F4~F8: 改变背景
' Esc: 退出
'直接在QB环境下运行速度很慢，编译为exe后就快些了
'展示了以下技术：
'1.QB在 VGA 12h 如何快速绘图
'2.有序抖动算法的实现
'3.模拟Windows窗口，特别是像Windows 98那样的渐变标题栏
'== Rect =====================================================================
TYPE Rect
Left AS INTEGER
Top AS INTEGER
Right AS INTEGER
Bottom AS INTEGER
END TYPE
CONST RectNoNum = &H8000
DECLARE FUNCTION GetRectW% (rct AS Rect)
DECLARE FUNCTION GetRectH% (rct AS Rect)
DECLARE SUB SetRect (rct AS Rect, x1%, y1%, x2%, y2%)
DECLARE SUB SetRectPos (rct AS Rect, x%, y%)
DECLARE SUB SetRectSize (rct AS Rect, w%, h%)
DECLARE SUB MoveRect (rct AS Rect, x%, y%)
DECLARE SUB SizeRect (rct AS Rect, x%, y%)
DECLARE SUB SetRectMinMax (rct AS Rect, MinX%, MinY%, MaxX%, MaxY%)
DECLARE SUB RectAddSize (rct AS Rect, xAdd AS INTEGER, yAdd AS INTEGER)
DECLARE FUNCTION RectIsNull% (rct AS Rect)
'== Bit ======================================================================
DECLARE SUB InitBit ()
DECLARE FUNCTION MakeWord% (LoByte AS INTEGER, HiByte AS INTEGER)
CONST True = -1
CONST False = 0
'== MemCopy ==================================================================
DECLARE SUB InitMemCopy ()
DECLARE SUB MemCopy (fromseg%, fromoffset%, toseg%, tooffset%, bytes%)
'== Font =====================================================================
DECLARE SUB InitFont ()
DECLARE SUB DrawText (rct AS Rect, DrawStr AS STRING)
DECLARE SUB DrawTextEx (rct AS Rect, StepX AS INTEGER, StepY AS INTEGER, DrawStr AS STRING, c AS INTEGER)
CONST CharWi = 8
CONST CharHe = 16
'== Color ====================================================================
DECLARE SUB InitLightM ()
DECLARE FUNCTION RGB12% (x%, y%, R%, G%, B%)
'== Draw =====================================================================
DECLARE SUB DrawEdge (qrc AS Rect, Edge AS INTEGER)
DECLARE SUB DrawEdge0 (qrc AS Rect, Edge AS INTEGER)
CONST BdrRAISEDOUTER = &H1 '外层凸
CONST BdrSUNKENOUTER = &H2 '外层凹
CONST BdrRAISEDINNER = &H4 '内层凸
CONST BdrSUNKENINNER = &H8 '内层凹
CONST BdrRAISED = &H5 '凸
CONST BdrSUNKEN = &HA '凹
CONST BdrOuter = &H3 '外
CONST BdrInner = &HC '内
CONST EdgeRAISED = (BdrRAISEDOUTER OR BdrRAISEDINNER)
CONST EdgeETCHED = (BdrSUNKENOUTER OR BdrRAISEDINNER)
CONST EdgeBUMP = (BdrRAISEDOUTER OR BdrSUNKENINNER)
CONST EdgeSUNKEN = (BdrSUNKENOUTER OR BdrSUNKENINNER)
DECLARE SUB FillRect (rct AS Rect, c AS INTEGER)
CONST OnlyLine = &H8000
DECLARE SUB GradH12 (rct AS Rect, cl%, cr%)
DECLARE SUB GradV12 (rct AS Rect, ct%, cb%)
DECLARE SUB DrawForm (rct AS Rect, TitleStr AS STRING)
DECLARE SUB DrawCaption (rct AS Rect, TitleStr AS STRING)
'== Shared Var ===============================================================
DIM SHARED BitMaskInt(0 TO &HF) AS INTEGER
DIM SHARED ASM.MemCopy AS STRING * 28
DIM SHARED FontData(0 TO &HF, 0 TO &HFF) AS INTEGER
DIM SHARED TextC AS INTEGER
DIM SHARED TextStepX AS INTEGER
DIM SHARED TextStepY AS INTEGER
DIM SHARED TextLf AS INTEGER
DIM SHARED AutoLf AS INTEGER
DIM SHARED CharAdd AS INTEGER
DIM SHARED LineAdd AS INTEGER
DIM SHARED BaseLightnessMatrix(0 TO 15, 0 TO 15) AS INTEGER
DIM SHARED LightnessMatrix(0 TO 15, 0 TO 15) AS INTEGER
DIM SHARED RGBIndex(0 TO 1, 0 TO 1, o TO 1) AS INTEGER
'== Const ====================================================================
CONST MyTitle = "View RGB (For QB) V1.0"
CONST ScrColor = 3
CONST ScrWi = 640
CONST ScrHe = 480
CONST MaxWi = ScrWi - 1
CONST MaxHe = ScrHe - 1
CONST TitleHe = 18
CONST TitleLC = 1
CONST TitleRC = 9
CONST CapHe = 1 + TitleHe + 1
CONST EdgeSize = 2
CONST FormBkC = 7
CONST FormTitleC = &HF
CONST FormTop = EdgeSize + CapHe
CONST FormLeft = EdgeSize + 1
CONST FormRight = EdgeSize + 1
CONST FormBottom = EdgeSize + 1
CONST FormStep = 4
CONST MapWi = &H100
CONST MapHe = &H100
CONST MaxMapWi = MapWi - 1
CONST MaxMapHe = MapHe - 1
CONST SolWi = &H10
CONST CurW = 8
CONST CurH = 5
'== Var ======================================================================
DIM I AS INTEGER, J AS INTEGER, K AS INTEGER
DIM ScrRect AS Rect
DIM FormRect AS Rect
DIM MyMap(0 TO ((MapWi / 8) * 4 / 2) * MapHe + 1) AS INTEGER
DIM valueB AS INTEGER
DIM Idx0 AS INTEGER, Idx AS INTEGER, CurIdx AS INTEGER
DIM TempInt(0 TO 3) AS INTEGER
DIM c AS INTEGER
DIM rct AS Rect
DIM HSB(0 TO 6) AS INTEGER
DIM ik AS STRING
DIM KeyCode AS INTEGER
DIM CurMap(0 TO ((CurW + 7) / 8) * 4 * CurH / 2 + 1) AS INTEGER
'== Begin ====================================================================
SCREEN 12
InitMemCopy
InitBit
InitFont
InitLightM
GOSUB LoadCur
HSB(0) = &HC
HSB(1) = &HE
HSB(2) = &HA
HSB(3) = &HB
HSB(4) = &H9
HSB(5) = &HD
HSB(6) = &HC
SetRect ScrRect, 0, 0, ScrWi, ScrHe
FillRect ScrRect, ScrColor
'GradV12 ScrRect, 10, 2
WHILE INKEY$ <> "": WEND 'Clean Key
GOSUB MakeMap
FormRect.Left = 0
FormRect.Top = 0
FormRect.Right = FormLeft + FormStep + MapWi + FormStep + SolWi + CurW + FormStep + FormRight
FormRect.Bottom = FormTop + FormStep + MapHe + FormStep + FormBottom
SetRectPos FormRect, (ScrWi - FormRect.Right) / 2, (ScrHe - FormRect.Bottom) / 2
GOSUB DrawMe
'WHILE INKEY$ = "": WEND
DO
ik = INKEY$
IF ik <> "" THEN
IF LEN(ik) > 1 THEN
KeyCode = ASC(MID$(ik, 2, 1))
SELECT CASE KeyCode
CASE 72'Up
IF valueB > 0 THEN
GOSUB DrawCur
valueB = valueB - 1
GOSUB DrawCur
GOSUB MakeMap
GOSUB DrawMap
END IF
CASE 80'Down
IF valueB < &HFF THEN
GOSUB DrawCur
valueB = valueB + 1
GOSUB DrawCur
GOSUB MakeMap
GOSUB DrawMap
END IF
CASE 73 'PageUp
IF valueB > 0 THEN
GOSUB DrawCur
valueB = valueB - &H10
IF valueB < 0 THEN valueB = 0
GOSUB DrawCur
GOSUB MakeMap
GOSUB DrawMap
END IF
CASE 81 'PageDown
IF valueB < &HFF THEN
GOSUB DrawCur
valueB = valueB + &H10
IF valueB > &HFF THEN valueB = &HFF
GOSUB DrawCur
GOSUB MakeMap
GOSUB DrawMap
END IF
CASE 62 'F4
FillRect ScrRect, ScrColor
GOSUB DrawMe
CASE 63 'F5
GradH12 ScrRect, 10, 2
GOSUB DrawMe
CASE 64 'F6
GradV12 ScrRect, 10, 2
GOSUB DrawMe
CASE 65 'F7
rct.Top = 0
rct.Bottom = ScrHe
FOR I = 1 TO 6
rct.Left = (I - 1) * ScrWi / 6
rct.Right = I * ScrWi / 6
GradH12 rct, HSB(I - 1), HSB(I)
NEXT I
GOSUB DrawMe
CASE 66 'F8
rct.Left = 0
rct.Right = ScrWi
FOR I = 1 TO 6
rct.Top = (I - 1) * ScrHe / 6
rct.Bottom = I * ScrHe / 6
GradV12 rct, HSB(I - 1), HSB(I)
NEXT I
GOSUB DrawMe
END SELECT
ELSE
KeyCode = ASC(ik)
SELECT CASE KeyCode
CASE 27 'Esc
EXIT DO
END SELECT
END IF
END IF
LOOP
SCREEN 0
END
LoadCur:
LINE (0, 0)-(CurW - 1, CurH - 1), 0, BF
LINE (CurW / 2, 0)-(0, CurH / 2), &HF
LINE -(CurW / 2, CurH - 1), &HF
LINE -(CurW - 1, CurH - 1), &HF
LINE -(CurW - 1, 0), &HF
LINE -(CurW / 2, 0), &HF
PAINT (CurW / 2, CurH / 2), &HF
GET (0, 0)-(CurW - 1, CurH - 1), CurMap
'WHILE INKEY$ = "": WEND
RETURN
DrawCur:
PUT (FormRect.Left + FormLeft + FormStep + MapWi + FormStep + SolWi, FormRect.Top + FormTop + FormStep + valueB - CurH / 2), CurMap, XOR
RETURN
MakeMap:
MyMap(0) = MapWi
MyMap(1) = MapHe
Idx0 = 2
FOR I = 0 TO MaxMapHe
FOR J = 0 TO MaxMapWi
CurIdx = J AND &HF
IF CurIdx = 0 THEN
FOR K = 0 TO 3
TempInt(K) = 0
NEXT K
END IF
c = RGB12(I, J, I, J, valueB)
FOR K = 0 TO 3
IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(CurIdx)
NEXT K
IF CurIdx = &HF THEN
Idx = Idx0
FOR K = 0 TO 3
MyMap(Idx) = TempInt(K)
Idx = Idx + &H10 'MapWi/8/2
NEXT K
Idx0 = Idx0 + 1
END IF
NEXT J
Idx0 = Idx0 + &H30 '(MapWi/8/2)*3
NEXT I
RETURN
DrawMap:
PUT (FormRect.Left + FormLeft + FormStep, FormRect.Top + FormTop + FormStep), MyMap, PSET
RETURN
DrawMe:
DrawForm FormRect, MyTitle
SetRect rct, 0, 0, SolWi, MapHe
MoveRect rct, FormLeft + FormStep + MapWi + FormStep, FormTop + FormStep
MoveRect rct, FormRect.Left, FormRect.Top
GradV12 rct, 0, 9
GOSUB DrawMap
GOSUB DrawCur
RETURN
'有序抖动亮度趋势矩阵
DATA 00,EB,3B,DB,0F,E7,37,D7,02,E8,38,D9,0C,E5,34,D5
DATA 80,40,BB,7B,8F,4F,B7,77,82,42,B8,78,8C,4C,B4,74
DATA 21,C0,10,FB,2F,CF,1F,F7,22,C2,12,F8,2C,CC,1C,F4
DATA A1,61,90,50,AF,6F,9F,5F,A2,62,92,52,AC,6C,9C,5C
DATA 08,E1,30,D0,05,EF,3F,DF,0A,E2,32,D2,06,EC,3C,DC
DATA 88,48,B0,70,85,45,BF,7F,8A,4A,B2,72,86,46,BC,7C
DATA 29,C8,18,F0,24,C5,14,FF,2A,CA,1A,F2,26,C6,16,FC
DATA A9,69,98,58,A4,64,94,54,AA,6A,9A,5A,A6,66,96,56
DATA 03,E9,39,D8,0D,E4,35,D4,01,EA,3A,DA,0E,E6,36,D6
DATA 83,43,B9,79,8D,4D,B5,75,81,41,BA,7A,8E,4E,B6,76
DATA 23,C3,13,F9,2D,CD,1D,F5,20,C1,11,FA,2E,CE,1E,F6
DATA A3,63,93,53,AD,6D,9D,5D,A0,60,91,51,AE,6E,9E,5E
DATA 0B,E3,33,D3,07,ED,3D,DD,09,E0,31,D1,04,EE,3E,DE
DATA 8B,4B,B3,73,87,47,BD,7D,89,49,B1,71,84,44,BE,7E
DATA 2B,CB,1B,F3,27,C7,17,FD,28,C9,19,F1,25,C4,15,FE
DATA AB,6B,9B,5B,A7,67,97,57,A8,68,99,59,A5,65,95,55
SUB DrawCaption (rct AS Rect, TitleStr AS STRING)
DIM TempRect AS Rect
TempRect.Left = rct.Left + EdgeSize
TempRect.Top = rct.Top + EdgeSize
TempRect.Right = rct.Right - EdgeSize
SetRectSize TempRect, RectNoNum, CapHe
FillRect TempRect, FormBkC OR OnlyLine
SizeRect TempRect, -1, -1
GradH12 TempRect, TitleLC, TitleRC
DrawTextEx TempRect, 3, 1, TitleStr, FormTitleC
END SUB
SUB DrawEdge (qrc AS Rect, Edge AS INTEGER)
DIM Inner AS INTEGER, Outer AS INTEGER
DIM TempRect AS Rect
Inner = Edge AND BdrInner
Outer = Edge AND BdrOuter
TempRect = qrc
IF Outer = 0 THEN
ELSEIF Outer = BdrOuter THEN
ELSE
DrawEdge0 TempRect, Outer
SizeRect TempRect, -1, -1
END IF
IF Inner = 0 THEN
ELSEIF Inner = BdrInner THEN
ELSE
DrawEdge0 TempRect, Inner
END IF
END SUB
SUB DrawEdge0 (qrc AS Rect, Edge AS INTEGER)
CONST c0 = &H0
CONST c1 = &H8
CONST c2 = &H7
CONST c3 = &HF
DIM clt AS INTEGER, crb AS INTEGER
IF qrc.Right <= qrc.Left THEN EXIT SUB
IF qrc.Bottom <= qrc.Top THEN EXIT SUB
SELECT CASE Edge
CASE BdrRAISEDOUTER
clt = c2
crb = c0
CASE BdrSUNKENOUTER
clt = c1
crb = c3
CASE BdrRAISEDINNER
clt = c3
crb = c1
CASE BdrSUNKENINNER
clt = c0
crb = c2
END SELECT
LINE (qrc.Left, qrc.Top)-(qrc.Right - 1, qrc.Top), clt
LINE (qrc.Left, qrc.Top)-(qrc.Left, qrc.Bottom - 1), clt
LINE (qrc.Right - 1, qrc.Top)-(qrc.Right - 1, qrc.Bottom - 1), crb
LINE (qrc.Left, qrc.Bottom - 1)-(qrc.Right - 1, qrc.Bottom - 1), crb
END SUB
SUB DrawForm (rct AS Rect, TitleStr AS STRING)
FillRect rct, FormBkC
DrawEdge rct, EdgeRAISED
DrawCaption rct, TitleStr
END SUB
SUB DrawText (rct AS Rect, DrawStr AS STRING)
DIM TempRect AS Rect
DIM PosX AS INTEGER, PosY AS INTEGER
DIM StrLen AS INTEGER
DIM StrPos AS INTEGER
DIM c AS STRING * 1
DIM FontPos AS INTEGER
DIM DrawMinX AS INTEGER, DrawMinY AS INTEGER
DIM DrawMaxX AS INTEGER, DrawMaxY AS INTEGER
DIM DrawY AS INTEGER
DIM DrawX1 AS INTEGER, DrawX2 AS INTEGER
DIM ExitFlags AS INTEGER
DIM I AS INTEGER
DIM MinI AS INTEGER, MaxI AS INTEGER
DIM TempNum AS INTEGER
PosX = rct.Left + TextStepX
PosY = rct.Top + TextStepY
TempRect = rct
'PRINT rct.Top, rct.Bottom
SetRectMinMax TempRect, 0, 0, ScrWi, ScrHe
IF RectIsNull(TempRect) THEN EXIT SUB
RectAddSize TempRect, -1, -1
'PRINT TempRect.Top, TempRect.Bottom
DrawMinX = TempRect.Left - (CharWi - 1)
DrawMinY = TempRect.Top - (CharHe - 1)
DrawMaxX = TempRect.Right + (CharWi - 1)
DrawMaxY = TempRect.Bottom + (CharHe - 1)
'PRINT DrawMinY, DrawMaxY
DrawX1 = PosX
DrawY = PosY
StrLen = LEN(DrawStr)
IF StrLen = 0 THEN EXIT SUB
StrPos = 1
'PRINT StrLen
DO
c = MID$(DrawStr, StrPos, 1)
FontPos = ASC(c)
'PRINT TextLf; c; " ";
IF ((FontPos = 13) OR (FontPos = 10)) AND TextLf THEN
'PRINT FontPos
DrawX1 = PosX
DrawY = DrawY + LineAdd
IF StrPos < StrLen OR FontPos = 13 THEN 'CrLf
IF ASC(MID$(DrawStr, StrPos + 1, 1)) = 10 THEN StrPos = StrPos + 1
END IF
END IF
IF DrawX1 + CharWi >= TempRect.Right THEN
IF AutoLf THEN
DrawX1 = PosX
DrawY = DrawY + LineAdd
ELSE
ExitFlags = True
END IF
END IF
IF DrawY >= DrawMinY AND DrawY <= DrawMaxY THEN
DrawX2 = DrawX1 + CharWi - 1
IF DrawX2 >= DrawMinX OR DrawX1 <= DrawMaxX THEN
IF DrawX1 < TempRect.Left THEN DrawX1 = TempRect.Left
IF DrawX1 > TempRect.Right THEN DrawX1 = TempRect.Right
IF DrawX2 < TempRect.Left THEN DrawX2 = TempRect.Left
IF DrawX2 > TempRect.Right THEN DrawX2 = TempRect.Right
DrawX2 = DrawX2 - DrawX1
TempNum = DrawY
IF TempNum < TempRect.Top THEN TempNum = TempRect.Top
IF TempNum > TempRect.Bottom THEN TempNum = TempRect.Bottom
MinI = TempNum - DrawY
TempNum = DrawY + CharHe - 1
IF TempNum < TempRect.Top THEN TempNum = TempRect.Top
IF TempNum > TempRect.Bottom THEN TempNum = TempRect.Bottom
MaxI = TempNum - DrawY
FOR I = MinI TO MaxI
LINE (DrawX1, DrawY + I)-STEP(DrawX2, 0), TextC, , FontData(I, FontPos)
NEXT I
END IF
END IF
DrawX1 = DrawX1 + CharAdd
StrPos = StrPos + 1
IF StrPos > StrLen THEN ExitFlags = True
'ExitFlags = True
LOOP UNTIL ExitFlags
END SUB
SUB DrawTextEx (rct AS Rect, StepX AS INTEGER, StepY AS INTEGER, DrawStr AS STRING, c AS INTEGER)
DIM tX AS INTEGER, tY AS INTEGER
DIM tC AS INTEGER
tX = TextStepX
TextStepX = StepX
tY = TextStepY
TextStepY = StepY
tC = TextC
TextC = c
DrawText rct, DrawStr
TextStepX = tX
TextStepY = tY
TectX = tC
END SUB
SUB FillRect (rct AS Rect, c AS INTEGER)
IF c AND OnlyLine THEN
LINE (rct.Left, rct.Top)-(rct.Right - 1, rct.Bottom - 1), c AND &HFF, B
ELSE
LINE (rct.Left, rct.Top)-(rct.Right - 1, rct.Bottom - 1), c, BF
END IF
END SUB
FUNCTION GetRectH% (rct AS Rect)
GetRectH% = rct.Bottom - rct.Top
END FUNCTION
FUNCTION GetRectW% (rct AS Rect)
GetRectW% = rct.Right - rct.Left
END FUNCTION
SUB GradH12 (rct AS Rect, cl%, cr%)
DIM w AS INTEGER, h AS INTEGER
DIM I AS INTEGER, J AS INTEGER, K AS INTEGER
DIM DataArr(I) AS INTEGER
DIM MapArr(I) AS INTEGER
DIM Idx AS INTEGER
DIM StartIdx AS INTEGER
DIM Idx0 AS INTEGER, Idx1 AS INTEGER
DIM ChanBytes AS INTEGER, ChanInts AS INTEGER
DIM TempInt(0 TO 3) AS INTEGER
'DIM TempNum AS INTEGER
DIM c AS INTEGER
w = GetRectW(rct)
h = GetRectH(rct)
'PRINT w, h
IF h <= 0 THEN EXIT SUB
IF w <= 2 THEN EXIT SUB
ChanBytes = (w + 7) / 8
ChanInts = (ChanBytes + 1) / 2
REDIM MapArr(0 TO ChanBytes * 2 + 1) AS INTEGER 'ChanBytes*4/2=ChanBytes*2
MapArr(0) = w
MapArr(1) = 1
w = w - 1
h = h - 1
REDIM DataArr(0 TO w) AS INTEGER
FOR I = 0 TO w
DataArr(I) = I * &H100& / w
NEXT I
IF (ChanBytes AND 1) = 0 THEN
FOR I = 0 TO h
StartIdx = 2
FOR J = 0 TO w
Idx = J AND &HF
IF BaseLightnessMatrix(Idx, I AND &HF) >= DataArr(J) THEN c = cl% ELSE c = cr%
FOR K = 0 TO 3
IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(Idx)
NEXT K
IF Idx = &HF OR J = w THEN
Idx0 = StartIdx
FOR K = 0 TO 3
MapArr(Idx0) = TempInt(K)
Idx0 = Idx0 + ChanInts
TempInt(K) = 0
NEXT K
StartIdx = StartIdx + 1
END IF
NEXT J
PUT (rct.Left, rct.Top + I), MapArr, PSET
NEXT I
ELSE
DIM TempArr(0 TO ChanInts - 1, 0 TO 1) AS INTEGER
FOR I = 0 TO h
StartIdx = 2
Idx1 = 0
FOR J = 0 TO w
Idx = J AND &HF
IF LightnessMatrix(Idx, I AND &HF) >= DataArr(J) THEN c = cl% ELSE c = cr%
FOR K = 0 TO 3
IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(Idx)
NEXT K
IF Idx = &HF OR J = w THEN
Idx0 = StartIdx
FOR K = 0 TO 3 STEP 2
MapArr(Idx0) = TempInt(K)
TempArr(Idx1, K / 2) = TempInt(K + 1)
Idx0 = Idx0 + ChanBytes
TempInt(K) = 0
TempInt(K + 1) = 0
NEXT K
StartIdx = StartIdx + 1
Idx1 = Idx1 + 1
END IF
NEXT J
Idx0 = VARSEG(MapArr(0))
Idx1 = VARPTR(MapArr(0))
Idx1 = Idx1 + 2 * 2 + ChanBytes
MemCopy VARSEG(TempArr(0, 0)), VARPTR(TempArr(0, 0)), Idx0, Idx1, ChanBytes
Idx1 = Idx1 + ChanBytes * 2
MemCopy VARSEG(TempArr(0, 1)), VARPTR(TempArr(0, 1)), Idx0, Idx1, ChanBytes
PUT (rct.Left, rct.Top + I), MapArr, PSET
NEXT I
END IF
END SUB
SUB GradV12 (rct AS Rect, ct%, cb%)
DIM w AS INTEGER, h AS INTEGER
DIM I AS INTEGER, J AS INTEGER, K AS INTEGER
DIM DataArr(I) AS INTEGER
DIM MapArr(I) AS INTEGER
DIM Idx AS INTEGER
DIM StartIdx AS INTEGER
DIM Idx0 AS INTEGER, Idx1 AS INTEGER
DIM ChanBytes AS INTEGER, ChanInts AS INTEGER
DIM TempInt(0 TO 3) AS INTEGER
DIM TempNum AS INTEGER
DIM c AS INTEGER
w = GetRectW(rct)
h = GetRectH(rct)
'PRINT w, h
IF w <= 0 THEN EXIT SUB
IF h <= 2 THEN EXIT SUB
ChanBytes = (w + 7) / 8
ChanInts = (ChanBytes + 1) / 2
REDIM MapArr(0 TO ChanBytes * 2 + 1) AS INTEGER 'ChanBytes*4/2=ChanBytes*2
MapArr(0) = w
MapArr(1) = 1
w = w - 1
h = h - 1
IF (ChanBytes AND 1) = 0 THEN
FOR I = 0 TO h
StartIdx = 2
TempNum = I * &H100& / h
FOR J = 0 TO w
Idx = J AND &HF
IF BaseLightnessMatrix(Idx, I AND &HF) >= TempNum THEN c = ct% ELSE c = cb%
FOR K = 0 TO 3
IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(Idx)
NEXT K
IF Idx = &HF OR J = w THEN
Idx0 = StartIdx
FOR K = 0 TO 3
MapArr(Idx0) = TempInt(K)
Idx0 = Idx0 + ChanInts
TempInt(K) = 0
NEXT K
StartIdx = StartIdx + 1
END IF
NEXT J
PUT (rct.Left, rct.Top + I), MapArr, PSET
NEXT I
ELSE
DIM TempArr(0 TO ChanInts - 1, 0 TO 1) AS INTEGER
FOR I = 0 TO h
StartIdx = 2
Idx1 = 0
TempNum = I * &HFF& / h
FOR J = 0 TO w
Idx = J AND &HF
IF LightnessMatrix(Idx, I AND &HF) >= TempNum THEN c = ct% ELSE c = cb%
FOR K = 0 TO 3
IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(Idx)
NEXT K
IF Idx = &HF OR J = w THEN
Idx0 = StartIdx
FOR K = 0 TO 3 STEP 2
MapArr(Idx0) = TempInt(K)
TempArr(Idx1, K / 2) = TempInt(K + 1)
Idx0 = Idx0 + ChanBytes
TempInt(K) = 0
TempInt(K + 1) = 0
NEXT K
StartIdx = StartIdx + 1
Idx1 = Idx1 + 1
END IF
NEXT J
Idx0 = VARSEG(MapArr(0))
Idx1 = VARPTR(MapArr(0))
Idx1 = Idx1 + 2 * 2 + ChanBytes
MemCopy VARSEG(TempArr(0, 0)), VARPTR(TempArr(0, 0)), Idx0, Idx1, ChanBytes
Idx1 = Idx1 + ChanBytes * 2
MemCopy VARSEG(TempArr(0, 1)), VARPTR(TempArr(0, 1)), Idx0, Idx1, ChanBytes
PUT (rct.Left, rct.Top + I), MapArr, PSET
NEXT I
END IF
END SUB
SUB InitBit
DIM I AS INTEGER
FOR I = 0 TO 7
BitMaskInt(I) = 2 ^ (7 - I)
NEXT I
BitMaskInt(8) = &H8000
FOR I = 9 TO &HF
BitMaskInt(I) = 2 ^ (&H17 - I)
NEXT I
END SUB
SUB InitFont
DIM I AS INTEGER, J AS INTEGER
DIM TempPos AS INTEGER
DIM TempByte AS INTEGER
SCREEN 12
WIDTH 80, 30
DEF SEG = &HA000
FOR I = 0 TO &HFF
LINE (0, 0)-(&HF, &HF), 0, BF
LOCATE 1, 1
PRINT CHR$(I)
TempPos = 0
FOR J = 0 TO &HF
TempByte = PEEK(TempPos)
FontData(J, I) = MakeWord(0, TempByte)
TempPos = TempPos + 80 '=640/8
NEXT J
'WHILE INKEY$ = "": WEND
NEXT I
DEF SEG
TextC = 15
TextLf = True
AutoLf = False
TextStepX = 0
TextStepY = 0
CharAdd = CharWi
LineAdd = CharHe
CLS
END SUB
SUB InitLightM
DIM I AS INTEGER, J AS INTEGER, K AS INTEGER
DIM TempStr AS STRING
DIM TempNum AS INTEGER
FOR I = 0 TO &HF
FOR J = 0 TO &HF
READ TempStr
TempNum = VAL("&H" + TempStr)
BaseLightnessMatrix(I, J) = TempNum
'这样做是为了简化运算，原来需要乘除运算（R*&H100/&HFF>L），现在只需要比较（R>=L），具体可看RGB12函数
IF TempNum <= &H7F THEN TempNum = TempNum + 1
LightnessMatrix(I, J) = TempNum
NEXT J
NEXT I
FOR I = 0 TO 1 'R
FOR J = 0 TO 1 'G
FOR K = 0 TO 1 'B
RGBIndex(I, J, K) = I * 4 OR J * 2 OR K OR 8
NEXT K
NEXT J
NEXT I
RGBIndex(0, 0, 0) = 0
END SUB
SUB InitMemCopy
DIM ASMStr AS STRING
ASMStr = ""
ASMStr = ASMStr + CHR$(85) 'PUSH BP
ASMStr = ASMStr + CHR$(137) + CHR$(229) 'MOV BP,SP
ASMStr = ASMStr + CHR$(30) 'PUSH DS
ASMStr = ASMStr + CHR$(139) + CHR$(70) + CHR$(10) 'MOV AX,[BP+0A]
ASMStr = ASMStr + CHR$(142) + CHR$(192) 'MOV ES,AX
ASMStr = ASMStr + CHR$(139) + CHR$(70) + CHR$(14) 'MOV AX,[BP+0E]
ASMStr = ASMStr + CHR$(142) + CHR$(216) 'MOV DS,AX
ASMStr = ASMStr + CHR$(139) + CHR$(118) + CHR$(12) 'MOV SI,[BP+0C]
ASMStr = ASMStr + CHR$(139) + CHR$(126) + CHR$(8) 'MOV DI,[BP+08]
ASMStr = ASMStr + CHR$(139) + CHR$(78) + CHR$(6) 'MOV CX,[BP+06]
ASMStr = ASMStr + CHR$(243) 'REPZ
ASMStr = ASMStr + CHR$(164) 'MOVSB
ASMStr = ASMStr + CHR$(31) 'POP DS
ASMStr = ASMStr + CHR$(93) 'POP BP
ASMStr = ASMStr + CHR$(203) 'RETF
'PRINT LEN(ASMStr)
'STOP
ASM.MemCopy = ASMStr
END SUB
FUNCTION MakeWord% (LoByte AS INTEGER, HiByte AS INTEGER)
MakeWord% = (LoByte AND &HFF) OR ((HiByte AND &H7F) * &H100) OR ((HiByte AND &H80) <> 0 AND &H8000)
END FUNCTION
SUB MemCopy (fromseg%, fromoffset%, toseg%, tooffset%, bytes%)
DEF SEG = VARSEG(ASM.MemCopy)
CALL Absolute(BYVAL fromseg%, BYVAL fromoffset%, BYVAL toseg%, BYVAL tooffset%, BYVAL bytes%, VARPTR(ASM.MemCopy))
DEF SEG
END SUB
SUB MoveRect (rct AS Rect, x%, y%)
rct.Left = rct.Left + x%
rct.Top = rct.Top + y%
rct.Right = rct.Right + x%
rct.Bottom = rct.Bottom + y%
END SUB
SUB RectAddSize (rct AS Rect, xAdd AS INTEGER, yAdd AS INTEGER)
rct.Right = rct.Right + xAdd
rct.Bottom = rct.Bottom + yAdd
END SUB
FUNCTION RectIsNull% (rct AS Rect)
RectIsNull% = (rct.Right <= rct.Left) OR (rct.Bottom <= rct.Top)
END FUNCTION
FUNCTION RGB12% (x%, y%, R%, G%, B%)
'DIM L AS INTEGER
'L = LightnessMatrix(x% AND &HF, y% AND &HF)
'RGB12% = RGBIndex((R% >= L) AND 1, (G% >= L) AND 1, (B% >= L) AND 1)
'稍微移一下效果比较好
RGB12% = RGBIndex((R% >= LightnessMatrix(x% AND &HF, y% AND &HF)) AND 1, (G% >= LightnessMatrix(x% + 1 AND &HF, y% AND &HF)) AND 1, (B% >= LightnessMatrix(x% AND &HF, y% + 1 AND &HF)) AND 1)
END FUNCTION
SUB SetRect (rct AS Rect, x1%, y1%, x2%, y2%)
rct.Left = x1%
rct.Top = y1%
rct.Right = x2%
rct.Bottom = y2%
END SUB
SUB SetRectMinMax (rct AS Rect, MinX%, MinY%, MaxX%, MaxY%)
IF rct.Left < MinX% THEN rct.Left = MinX%
IF rct.Top < MinY% THEN rct.Top = MinY%
IF rct.Right > MaxX% THEN rct.Right = MaxX%
IF rct.Bottom > MaxY% THEN rct.Bottom = MaxY%
END SUB
SUB SetRectPos (rct AS Rect, x%, y%)
IF x% <> RectNoNum THEN rct.Right = x% + rct.Right - rct.Left: rct.Left = x%
IF y% <> RectNoNum THEN rct.Bottom = y% + rct.Bottom - rct.Top: rct.Top = y%
END SUB
SUB SetRectSize (rct AS Rect, w%, h%)
IF w% <> RectNoNum THEN rct.Right = rct.Left + w%
IF h% <> RectNoNum THEN rct.Bottom = rct.Top + h%
END SUB
SUB SizeRect (rct AS Rect, x%, y%)
rct.Left = rct.Left - x%
rct.Top = rct.Top - y%
rct.Right = rct.Right + x%
rct.Bottom = rct.Bottom + y%
END SUB
|
