'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 |
