1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
unit unit_yuv4mpeg2;{writes YUV4MPEG2 uncompressed video file. Pixels are taken from Timage}
{$MODE Delphi}
{Copyright (C) 2017, 2023 by Han Kleijn, www.hnsky.org
email: han.k.. at...hnsky.org
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0/. }
interface
uses
Classes, SysUtils,dialogs,graphics,
LCLType, // for RGBtriple
IntfGraphics, // TLazIntfImage type
fpImage, // TFPColor type;
lclintf;
function write_yuv4mpeg2_header(filen, framerate: string; colour : boolean; w,h: integer): boolean;{open/create file. Result is false if failure}
function write_yuv4mpeg2_frame(colour: boolean; x,y,w,h: integer): boolean; {reads pixels from Timage and writes YUV frames in 444p style, colour or mono. Call this procedure for each image. Result is false if failure}
procedure close_yuv4mpeg2; {close file}
implementation
uses astap_main;
var
theFile : tfilestream;
function write_yuv4mpeg2_header(filen, framerate: string; colour : boolean; w, h {size}: integer): boolean;{open/create file. Result is false if failure}
var
header: array[0..41] of ansichar;
begin
result:=false;
try
TheFile:=tfilestream.Create(filen, fmcreate );
except
TheFile.free;
exit;
end;
{'YUV4MPEG2 W0384 H0288 F01:1 Ip A0:0 C444'+#10} {See https://wiki.multimedia.cx/index.php/YUV4MPEG2}
if colour then header:=pansichar('YUV4MPEG2 W'+inttostr(w)+' H'+inttostr(h)+' F'+trim(framerate)+':1 Ip A0:0 C444'+#10)
else header:=pansichar('YUV4MPEG2 W'+inttostr(w)+' H'+inttostr(h)+' F'+trim(framerate)+':1 Ip A0:0 Cmono'+#10);{width, height,frame rate, interlace progressive, unknown aspect, color space}
{ Write header }
thefile.writebuffer ( header, strlen(Header));
result:=true;
end;
function write_yuv4mpeg2_frame(colour: boolean;x,y,w,h: integer): boolean; {reads pixels from Timage and writes YUV frames in 444p style, colour or mono. Call this procedure for each image}
var
k,xx,yy,steps : integer;
r,g,b : byte;
row : array of byte;
xLine : PByteArray;
const
header: array[0..5] of ansichar=(('F'),('R'),('A'),('M'),('E'),(#10));
begin
result:=true;
try
thefile.writebuffer ( header, strlen(header)); {write FRAME+#10}
setlength(row, w {width});
{444 frames: Y0 (full frame), U0,V0 Y1 U1 V1 Y2 U2 V2 422 frames: Y0 (U0+U1)/2 Y1 (V0+V1)/2 Y2 (U2+U3)/2 Y3 (V2+V3)/2}
// write full Y frame
//YYYY
//YYYY
//YYYY
//YYYY
// write full U frame
//UUUU
//UUUU
//UUUU
//UUUU
// write full V frame
//VVVV
//VVVV
//VVVV
//VVVV
if colour then steps:=2 {colour} else steps:=0;{mono} {for colour write Y, U, V frame else only Y}
for k:=0 to steps {0 or 2} do {do Y,U, V frame, so scan image line 3 times}
for yy := y to y+h-1 {height} do
begin // scan each timage line
xLine:=mainwindow.image1.Picture.Bitmap.ScanLine[yy];
for xx := x to x+w-1 {width} do
begin
{$ifdef mswindows}
B:=xLine^[xx*3]; {3*8=24 bit}
G:=xLine^[xx*3+1]; {fast pixel write routine }
R:=xLine^[xx*3+2];
{$endif}
{$ifdef darwin} {MacOS}
R:=xLine^[xx*4+1]; {4*8=32 bit}
G:=xLine^[xx*4+2]; {fast pixel write routine }
B:=xLine^[xx*4+3];
{$endif}
{$ifdef linux}
B:=xLine^[xx*4]; {4*8=32 bit}
G:=xLine^[xx*4+1]; {fast pixel write routine }
R:=xLine^[xx*4+2];
{$endif}
if k=0 then
row[xx-x]:=trunc(R*77/256 + G*150/256 + B*29/256) {Y frame, Full swing for BT.601}
else
if k=1 then
row[xx-x]:=trunc(R*-43/256 + G*-84/256 + B*127/256 +128) {U frame}
else
row[xx-x]:=trunc(R*127/256 + G*-106/256 + B*-21/256 +128){V frame}
end;
thefile.writebuffer(row[0],length(row));
end;
except
result:=false;
row:=nil;
exit;
end;
row:=nil;
end;
procedure close_yuv4mpeg2; {close file}
begin
thefile.free;
end;
end.
|
